From: simonpj Date: Fri, 25 May 2001 08:55:04 +0000 (+0000) Subject: [project @ 2001-05-25 08:55:03 by simonpj] X-Git-Tag: Approximately_9120_patches~1877 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=3af411e913102d8ec1234f32abe99374f077e3f7;p=ghc-hetmet.git [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 --- diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index f068e30..dda8468 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -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. diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index a69c239..10ffe27 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -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 diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index e513548..e16847f 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -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} diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index 5881546..2a8eabe 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -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 diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 430cc9f..2cc84b2 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -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") diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index ec7c953..04da56d 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -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 diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 5168292..2de6d62 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -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} diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 615dea8..a656c38 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -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} diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 222b2a0..2e4e4e1 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -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