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.
coreExprCc,
flattenBinds,
- isValArg, isTypeArg, valArgCount, valBndrCount,
+ isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
-- Unfoldings
Unfolding(..), UnfoldingGuidance(..), -- Both abstract everywhere but in CoreUnfold.lhs
#include "HsVersions.h"
+import CmdLineOpts ( opt_RuntimeTypes )
import CostCentre ( CostCentre, noCostCentre )
import Var ( Var, Id, TyVar, isTyVar, isId )
import Type ( Type, mkTyVarTy, seqType )
%* *
%************************************************************************
+@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
exprIsValue,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsAtom,
idAppIsBottom, idAppIsCheap,
- exprArity, isRuntimeVar, isRuntimeArg,
+ exprArity,
-- Expr transformation
etaReduce, etaExpand,
import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply )
import Outputable
import TysPrim ( alphaTy ) -- Debugging only
-import CmdLineOpts ( opt_KeepStgTypes )
\end{code}
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
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}
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
-- 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
-- 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}
= 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
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
-- 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)
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))
| 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
(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
opt_Parallel,
opt_SMP,
opt_NoMonomorphismRestriction,
- opt_KeepStgTypes,
+ opt_RuntimeTypes,
-- optimisation opts
opt_NoMethodSharing,
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")
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
-- 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
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)
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
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]
\begin{code}
filterStgBinders :: [Var] -> [Var]
filterStgBinders bndrs
- | opt_KeepStgTypes = bndrs
+ | opt_RuntimeTypes = bndrs
| otherwise = filter isId bndrs
\end{code}
-- 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
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}
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}
------------ 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_`
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)
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}
(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}
-> 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
projects / ghc-hetmet.git / commitdiff