Commit 508aae27 authored by dsyme's avatar dsyme

[project @ 2001-05-24 15:10:19 by dsyme]

Various changes for ILX backend and type-passing compilers, code reviewed by SimonPJ
parent e266b13a
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -360,9 +360,7 @@ data HscLang
= HscC
| HscAsm
| HscJava
#ifdef ILX
| HscILX
#endif
| HscInterpreted
deriving (Eq, Show)
......
......@@ -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
}
......
{-# 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) )
......
-----------------------------------------------------------------------------
-- $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
......
-----------------------------------------------------------------------------
-- $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
......
......@@ -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}
......@@ -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}
......
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