From 508aae27ab8e5b4a3c518bdeeec4be5dbd540a4a Mon Sep 17 00:00:00 2001 From: dsyme Date: Thu, 24 May 2001 15:10:20 +0000 Subject: [PATCH] [project @ 2001-05-24 15:10:19 by dsyme] Various changes for ILX backend and type-passing compilers, code reviewed by SimonPJ --- ghc/compiler/basicTypes/Module.lhs | 10 ++++++ ghc/compiler/coreSyn/CoreUtils.lhs | 43 +++++++++++++++++++------ ghc/compiler/ilxGen/IlxGen.lhs | 15 ++++----- ghc/compiler/main/CmdLineOpts.lhs | 2 -- ghc/compiler/main/CodeOutput.lhs | 5 ++- ghc/compiler/main/DriverFlags.hs | 6 ++-- ghc/compiler/main/DriverPipeline.hs | 9 +----- ghc/compiler/main/DriverState.hs | 4 +-- ghc/compiler/stgSyn/CoreToStg.lhs | 60 ++++++++++++++++++++++++----------- ghc/compiler/stgSyn/StgSyn.lhs | 11 +++++-- 10 files changed, 110 insertions(+), 55 deletions(-) diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 4a74f9c..998dc1e 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -40,7 +40,9 @@ module Module , moduleUserString -- :: Module -> UserString , mkVanillaModule -- :: ModuleName -> Module + , isVanillaModule -- :: Module -> Bool , mkPrelModule -- :: UserString -> Module + , isPrelModule -- :: Module -> Bool , mkModule -- :: ModuleName -> PackageName -> Module , mkHomeModule -- :: ModuleName -> Module , isHomeModule -- :: Module -> Bool @@ -252,9 +254,17 @@ isHomeModule _ = False mkVanillaModule :: ModuleName -> Module mkVanillaModule name = Module name DunnoYet +isVanillaModule :: Module -> Bool +isVanillaModule (Module nm DunnoYet) = True +isVanillaModule _ = False + mkPrelModule :: ModuleName -> Module mkPrelModule name = mkModule name preludePackage +isPrelModule :: Module -> Bool +isPrelModule (Module nm (AnotherPackage p)) | p == preludePackage = True +isPrelModule _ = False + moduleString :: Module -> EncodedString moduleString (Module (ModuleName fs) _) = _UNPK_ fs diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 7241e08..e513548 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, + exprArity, isRuntimeVar, isRuntimeArg, -- Expr transformation etaReduce, etaExpand, @@ -60,13 +60,14 @@ import IdInfo ( LBVarInfo(..), import Demand ( appIsBottom ) import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, applyTys, isUnLiftedType, seqType, mkUTy, mkTyVarTy, - splitForAllTy_maybe, splitNewType_maybe + splitForAllTy_maybe, splitNewType_maybe, isForAllTy ) import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply ) import Outputable import TysPrim ( alphaTy ) -- Debugging only +import CmdLineOpts ( opt_KeepStgTypes ) \end{code} @@ -303,9 +304,9 @@ exprIsTrivial (Var v) | otherwise = True exprIsTrivial (Type _) = True exprIsTrivial (Lit lit) = True -exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e +exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e exprIsTrivial (Note _ e) = exprIsTrivial e -exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body +exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body exprIsTrivial other = False exprIsAtom :: CoreExpr -> Bool @@ -385,7 +386,7 @@ exprIsCheap (Type _) = True exprIsCheap (Var _) = True exprIsCheap (Note InlineMe e) = True exprIsCheap (Note _ e) = exprIsCheap e -exprIsCheap (Lam x e) = if isId x then True else exprIsCheap e +exprIsCheap (Lam x e) = isRuntimeVar x || exprIsCheap e exprIsCheap (Case e _ alts) = exprIsCheap e && and [exprIsCheap rhs | (_,_,rhs) <- alts] -- Experimentally, treat (case x of ...) as cheap @@ -411,7 +412,7 @@ exprIsCheap other_expr -- because it certainly doesn't need to be shared! go (App f a) n_args args_cheap - | isTypeArg a = go f n_args args_cheap + | not (isRuntimeArg a) = go f n_args args_cheap | otherwise = go f (n_args + 1) (exprIsCheap a && args_cheap) go other n_args args_cheap = False @@ -481,7 +482,7 @@ exprOkForSpeculation other_expr other -> False go (App f a) n_args args_ok - | isTypeArg a = go f n_args args_ok + | not (isRuntimeArg a) = go f n_args args_ok | otherwise = go f (n_args + 1) (exprOkForSpeculation a && args_ok) go other n_args args_ok = False @@ -530,7 +531,7 @@ exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind -- copying them exprIsValue (Lit l) = True -exprIsValue (Lam b e) = isId b || exprIsValue e +exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e exprIsValue (Note _ e) = exprIsValue e exprIsValue other_expr = go other_expr 0 @@ -538,7 +539,7 @@ exprIsValue other_expr go (Var f) n_args = idAppIsValue f n_args go (App f a) n_args - | isTypeArg a = go f n_args + | not (isRuntimeArg a) = go f n_args | otherwise = go f (n_args + 1) go (Note _ f) n_args = go f n_args @@ -556,7 +557,20 @@ 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 @@ -739,7 +753,16 @@ etaExpand :: Int -- Add this number of value args -- (/\b. coerce T (\y::A -> (coerce (A->B) (E b) y) etaExpand n us expr ty - | n == 0 -- Saturated, so nothing to do + | n == 0 && + -- The ILX code generator requires eta expansion for type arguments + -- too, but alas the 'n' doesn't tell us how many of them there + -- may be. So we eagerly eta expand any big lambdas, and just + -- cross our fingers about possible loss of sharing in the + -- ILX case. + -- The Right Thing is probably to make 'arity' include + -- type variables throughout the compiler. (ToDo.) + not (isForAllTy ty) + -- Saturated, so nothing to do = expr | otherwise -- An unsaturated constructor or primop; eta expand it diff --git a/ghc/compiler/ilxGen/IlxGen.lhs b/ghc/compiler/ilxGen/IlxGen.lhs index 02d151e..5881546 100644 --- a/ghc/compiler/ilxGen/IlxGen.lhs +++ b/ghc/compiler/ilxGen/IlxGen.lhs @@ -24,7 +24,7 @@ import DataCon ( isUnboxedTupleCon, dataConTyCon, dataConRepType, dataConRepArgT import Literal ( Literal(..) ) import PrelNames -- Lots of keys import PrimOp ( PrimOp(..) ) -import ForeignCall ( ForeignCall(..), CCall(..), CCallTarget(..) ) +import ForeignCall ( CCallConv(..), ForeignCall(..), CCallSpec(..), CCallTarget(..), DNCallSpec(..) ) import TysWiredIn ( mkTupleTy, tupleCon ) import PrimRep ( PrimRep(..) ) import Name ( nameModule, nameOccName, isGlobalName, isLocalName, NamedThing(getName) ) @@ -39,7 +39,6 @@ import Module ( Module, PackageName, ModuleName, moduleName, import UniqFM import BasicTypes ( Boxity(..) ) import CStrings ( CLabelString, pprCLabelString ) -import CCallConv ( CCallConv ) import Outputable import Char ( ord ) import List ( partition, elem, insertBy,any ) @@ -239,8 +238,8 @@ ilxTyCon env tycon = ilxTyConDef False env tycon -- filter to get only dataTyCons? ilxTyConDef importing env tycon = vcat [empty $$ line, - text ".classunion" <+> (if importing then text "extern" else empty) <+> text "thunk" - <+> ((nameReference env (getName tycon)) <> (ppr tycon)) <+> tyvars_text <+> alts_text] + text ".classunion" <+> (if importing then text "import" else empty) <+> tyvars_text <+> text ": thunk" + <> angleBrackets((nameReference env (getName tycon)) <> (ppr tycon)) <+> alts_text] where tyvars = tyConTyVars tycon (ilx_tvs, _) = categorizeTyVars tyvars @@ -1633,7 +1632,7 @@ tyPrimConTable = -- These can all also accept unlifted parameter types so we explicitly lift. (arrayPrimTyConKey, (\[ty] -> repArray (ilxTypeL2 ty))), (mutableArrayPrimTyConKey, (\[_, ty] -> repMutArray (ilxTypeL2 ty))), - (weakPrimTyConKey, (\[_, ty] -> repWeak (ilxTypeL2 ty))), + (weakPrimTyConKey, (\[ty] -> repWeak (ilxTypeL2 ty))), (mVarPrimTyConKey, (\[_, ty] -> repMVar (ilxTypeL2 ty))), (mutVarPrimTyConKey, (\[ty1, ty2] -> repMutVar (ilxTypeL2 ty1) (ilxTypeL2 ty2))), (mutableByteArrayPrimTyConKey, (\_ -> repByteArray)), @@ -2289,10 +2288,10 @@ ilxFCall env (CCall (CCallSpec (StaticTarget c) cconv gc)) args ret_ty <+> pprCValArgTys ilxTypeL env (map deepIlxRepType (filter (not. isVoidIlxRepType) (map stgArgType tm_args))) ] where retdoc | isVoidIlxRepType ret_ty = text "void" - | otherwis = ilxTypeR env (deepIlxRepType ret_ty) + | otherwise = ilxTypeR env (deepIlxRepType ret_ty) (ty_args,tm_args) = splitTyArgs1 args -ilxFCall env (CCall (DotNetCallSpec call_instr)) args ret_ty +ilxFCall env (CCall (DNCallSpec call_instr)) args ret_ty = ilxComment (text "IL call") <+> vcat [vcat (ilxMapPlaceArgs 0 pushILArg env tm_args), text call_instr @@ -2303,7 +2302,7 @@ ilxFCall env (CCall (DotNetCallSpec call_instr)) args ret_ty where (ty_args,tm_args) = splitTyArgs1 args -pushILArg env arg | isUnliftedType (stgArgType arg) = pushArg env arg +pushILArg env arg | isUnLiftedType (stgArgType arg) = pushArg env arg | otherwise = pushArg env arg <+> error "call ilxFunAppArgs" hasTyCon (TyConApp tc _) tc2 = tc == tc2 diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index ecf5018..430cc9f 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -360,9 +360,7 @@ data HscLang = HscC | HscAsm | HscJava -#ifdef ILX | HscILX -#endif | HscInterpreted deriving (Eq, Show) diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 1983acc..df6337d 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -75,9 +75,12 @@ codeOutput dflags mod_name tycons core_binds stg_binds >> return stub_names HscJava -> outputJava dflags filenm mod_name tycons core_binds >> return stub_names + HscILX -> #ifdef ILX - HscILX -> outputIlx dflags filenm mod_name tycons stg_binds + outputIlx dflags filenm mod_name tycons stg_binds >> return stub_names +#else + panic "ILX support not compiled into this ghc" #endif } diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index a22668e..9e7c97b 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -1,7 +1,7 @@ {-# OPTIONS -#include "hschooks.h" #-} ----------------------------------------------------------------------------- --- $Id: DriverFlags.hs,v 1.53 2001/05/09 09:38:18 simonmar Exp $ +-- $Id: DriverFlags.hs,v 1.54 2001/05/24 15:10:19 dsyme Exp $ -- -- Driver flags -- @@ -208,6 +208,7 @@ static_flags = , ( "osuf" , HasArg (writeIORef v_Object_suf . Just) ) , ( "hcsuf" , HasArg (writeIORef v_HC_suf . Just) ) , ( "hisuf" , HasArg (writeIORef v_Hi_suf) ) + , ( "buildtag" , HasArg (writeIORef v_Build_tag) ) , ( "tmpdir" , HasArg (writeIORef v_TmpDir . (++ "/")) ) , ( "ohi" , HasArg (writeIORef v_Output_hi . Just) ) -- -odump? @@ -341,6 +342,7 @@ setLang l = do case hscLang dfs of HscC -> writeIORef v_DynFlags dfs{ hscLang = l } HscAsm -> writeIORef v_DynFlags dfs{ hscLang = l } + HscILX -> writeIORef v_DynFlags dfs{ hscLang = l } _ -> return () setVerbosityAtLeast n = @@ -435,9 +437,7 @@ dynamic_flags = [ , ( "fasm", AnySuffix (\_ -> setLang HscAsm) ) , ( "fvia-c", NoArg (setLang HscC) ) , ( "fvia-C", NoArg (setLang HscC) ) -#ifdef ILX , ( "filx", NoArg (setLang HscILX) ) -#endif -- "active negatives" , ( "fno-implicit-prelude", NoArg (setDynFlag Opt_NoImplicitPrelude) ) diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 6e32929..22ab424 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPipeline.hs,v 1.68 2001/05/09 09:38:18 simonmar Exp $ +-- $Id: DriverPipeline.hs,v 1.69 2001/05/24 15:10:19 dsyme Exp $ -- -- GHC Driver -- @@ -148,9 +148,6 @@ genPipeline todo stop_flag persistent_output lang filename keep_hc <- readIORef v_Keep_hc_files keep_raw_s <- readIORef v_Keep_raw_s_files keep_s <- readIORef v_Keep_s_files -#ifdef ILX - writeIORef v_Object_suf (Just "ilx") -#endif osuf <- readIORef v_Object_suf hcsuf <- readIORef v_HC_suf @@ -189,10 +186,8 @@ genPipeline todo stop_flag persistent_output lang filename HscJava | split -> not_valid | otherwise -> error "not implemented: compiling via Java" -#ifdef ILX HscILX | split -> not_valid | otherwise -> [ Unlit, Cpp, Hsc ] -#endif | cish = [ Cc, As ] @@ -983,9 +978,7 @@ compile ghci_mode summary source_unchanged have_object HscAsm -> newTempName (phaseInputExt As) HscC -> newTempName (phaseInputExt HCc) HscJava -> newTempName "java" -- ToDo -#ifdef ILX HscILX -> newTempName "ilx" -- ToDo -#endif HscInterpreted -> return (error "no output file") let (basename, _) = splitFilename input_fn diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index 8591f8a..8556c18 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverState.hs,v 1.38 2001/05/09 09:38:18 simonmar Exp $ +-- $Id: DriverState.hs,v 1.39 2001/05/24 15:10:19 dsyme Exp $ -- -- Settings for the driver -- @@ -459,7 +459,7 @@ findBuildTag :: IO [String] -- new options findBuildTag = do way_names <- readIORef v_Ways case sort way_names of - [] -> do writeIORef v_Build_tag "" + [] -> do -- writeIORef v_Build_tag "" return [] [w] -> do let details = lkupWay w diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 07acdd3..ec7c953 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -19,7 +19,7 @@ import Type import TyCon ( isAlgTyCon ) import Literal import Id -import Var ( Var, globalIdDetails ) +import Var ( Var, globalIdDetails, varType ) import IdInfo import DataCon import CostCentre ( noCCS ) @@ -507,8 +507,21 @@ coreToStgApp maybe_thunk_body f args let n_val_args = valArgCount args not_letrec_bound = not (isLetBound how_bound) - fun_fvs = singletonFVInfo f how_bound fun_occ - + fun_fvs + = let fvs = singletonFVInfo f how_bound fun_occ in + -- 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 + fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f)) + else fvs + + -- Mostly, the arity info of a function is in the fn's IdInfo + -- But new bindings introduced by CoreSat may not have no + -- arity info; it would do us no good anyway. For example: + -- let f = \ab -> e in f + -- No point in having correct arity info for f! + -- Hence the hasArity stuff below. f_arity = case how_bound of LetBound _ _ arity -> arity _ -> 0 @@ -876,7 +889,7 @@ freeVarsToLiveVars fvs env live_in_cont = returnLne (lvs, cafs) env live_in_cont where (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match! - (local, global) = partition isLocalId (allFVs fvs) + (local, global) = partition isLocalId (allFreeIds fvs) (lvs_from_fvs, caf_extras) = unzip (map do_one local) @@ -894,7 +907,7 @@ freeVarsToLiveVars fvs env live_in_cont Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v) is_caf_one v - = case lookupVarEnv env v of + = case lookupVarEnv env v of Just (LetBound TopLevelHasCafs (lvs,_) _) -> ASSERT( isEmptyVarSet lvs ) True Just (LetBound _ _ _) -> False @@ -976,13 +989,15 @@ lookupFVInfo fvs id Nothing -> noBinderInfo Just (_,_,info) -> info -allFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only -allFVs fvs = [id | (id,_,_) <- rngVarEnv fvs] +allFreeIds :: FreeVarsInfo -> [Id] -- Non-top-level things only +allFreeIds fvs = [id | (id,_,_) <- rngVarEnv fvs, isId id] -getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only +-- Non-top-level things only, both type variables and ids (type variables +-- only if opt_KeepStgTypes. +getFVs :: FreeVarsInfo -> [Var] getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs] -getFVSet :: FreeVarsInfo -> IdSet +getFVSet :: FreeVarsInfo -> VarSet getFVSet fvs = mkVarSet (getFVs fvs) plusFVInfo (id1,top1,info1) (id2,top2,info2) @@ -1103,7 +1118,12 @@ rhsIsNonUpd :: CoreExpr -> Bool -- -- c) don't look through unfolding of f in (f x). I'm suspicious of this one -rhsIsNonUpd (Lam b e) = isId b || rhsIsNonUpd e +-- 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 +-- them as making the RHS re-entrant (non-updatable). +rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e rhsIsNonUpd (Note (SCC _) e) = False rhsIsNonUpd (Note _ e) = rhsIsNonUpd e rhsIsNonUpd other_expr @@ -1122,11 +1142,11 @@ rhsIsNonUpd other_expr idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool idAppIsNonUpd id n_val_args args - | Just con <- isDataConId_maybe id = not (isDynConApp con args) + | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args) | otherwise = n_val_args < idArity id -isDynConApp :: DataCon -> [CoreExpr] -> Bool -isDynConApp con args = isDllName (dataConName con) || any isDynArg args +isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool +isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args -- Top-level constructor applications can usually be allocated -- statically, but they can't if -- a) the constructor, or any of the arguments, come from another DLL @@ -1137,10 +1157,12 @@ isDynConApp con args = isDllName (dataConName con) || any isDynArg args -- All this should match the decision in (see CoreToStg.coreToStgRhs) -isDynArg :: CoreExpr -> Bool -isDynArg (Var v) = isDllName (idName v) -isDynArg (Note _ e) = isDynArg e -isDynArg (Lit lit) = isLitLitLit lit -isDynArg (App e _) = isDynArg e -- must be a type app -isDynArg (Lam _ e) = isDynArg e -- must be a type lam +isCrossDllArg :: CoreExpr -> Bool +-- True if somewhere in the expression there's a cross-DLL reference +isCrossDllArg (Type _) = False +isCrossDllArg (Var v) = isDllName (idName v) +isCrossDllArg (Note _ e) = isCrossDllArg e +isCrossDllArg (Lit lit) = isLitLitLit lit +isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2 -- must be a type app +isCrossDllArg (Lam v e) = isCrossDllArg e -- must be a type lam \end{code} diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index b100b1e..5168292 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -49,6 +49,7 @@ module StgSyn ( import CostCentre ( CostCentreStack, CostCentre ) import VarSet ( IdSet, isEmptyVarSet ) +import Var ( isId ) import Id ( Id, idName, idPrimRep, idType ) import Name ( isDllName ) import Literal ( Literal, literalType, isLitLitLit, literalPrimRep ) @@ -56,6 +57,7 @@ import ForeignCall ( ForeignCall ) import DataCon ( DataCon, dataConName ) import PrimOp ( PrimOp ) import Outputable +import Util ( count ) import Type ( Type ) import TyCon ( TyCon ) import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) @@ -111,6 +113,7 @@ isStgTypeArg other = False isDllArg :: StgArg -> Bool -- Does this argument refer to something in a different DLL? +isDllArg (StgTypeArg v) = False isDllArg (StgVarArg v) = isDllName (idName v) isDllArg (StgLitArg lit) = isLitLitLit lit @@ -124,6 +127,7 @@ stgArgType :: StgArg -> Type -- Very half baked becase we have lost the type arguments stgArgType (StgVarArg v) = idType v stgArgType (StgLitArg lit) = literalType lit +stgArgType (StgTypeArg lit) = panic "stgArgType called on stgTypeArg" \end{code} %************************************************************************ @@ -395,8 +399,11 @@ The second flavour of right-hand-side is for constructors (simple but important) \end{code} \begin{code} -stgRhsArity :: GenStgRhs bndr occ -> Int -stgRhsArity (StgRhsClosure _ _ _ _ args _) = length args +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. stgRhsArity (StgRhsCon _ _ _) = 0 \end{code} -- 1.7.10.4