Various changes for ILX backend and type-passing compilers, code reviewed by SimonPJ
, 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
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
exprIsValue,exprOkForSpeculation, exprIsBig,
exprIsConApp_maybe, exprIsAtom,
idAppIsBottom, idAppIsCheap,
- exprArity,
+ exprArity, isRuntimeVar, isRuntimeArg,
-- Expr transformation
etaReduce, etaExpand,
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}
| 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
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
-- 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
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
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
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
-- 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
-- (/\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
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) )
import UniqFM
import BasicTypes ( Boxity(..) )
import CStrings ( CLabelString, pprCLabelString )
-import CCallConv ( CCallConv )
import Outputable
import Char ( ord )
import List ( partition, elem, insertBy,any )
-- 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
-- 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)),
<+> 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
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
= HscC
| HscAsm
| HscJava
-#ifdef ILX
| HscILX
-#endif
| HscInterpreted
deriving (Eq, Show)
>> 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
}
{-# 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
--
, ( "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?
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 =
, ( "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) )
-----------------------------------------------------------------------------
--- $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
--
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
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 ]
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
-----------------------------------------------------------------------------
--- $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
--
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
import TyCon ( isAlgTyCon )
import Literal
import Id
-import Var ( Var, globalIdDetails )
+import Var ( Var, globalIdDetails, varType )
import IdInfo
import DataCon
import CostCentre ( noCCS )
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
= 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)
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
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)
--
-- 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
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
-- 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}
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 )
import DataCon ( DataCon, dataConName )
import PrimOp ( PrimOp )
import Outputable
+import Util ( count )
import Type ( Type )
import TyCon ( TyCon )
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
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
-- 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}
%************************************************************************
\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}
projects / ghc-hetmet.git / commitdiff