import Monad (mplus)
-- GHC
-import CmdLineOpts (opt_Flatten)
import Panic (panic)
import Outputable (Outputable(ppr), pprPanic)
import UniqSupply (UniqSupply, splitUniqSupply, uniqFromSupply)
-import OccName (UserFS)
-import Var (Var(..))
+import Var (Var, idType)
import Id (Id, mkSysLocal)
import Name (Name)
-import VarSet (VarSet, emptyVarSet, unitVarSet, extendVarSet,
- varSetElems, unionVarSet)
-import VarEnv (VarEnv, emptyVarEnv, unitVarEnv, zipVarEnv, plusVarEnv,
+import VarSet (VarSet, emptyVarSet, extendVarSet, varSetElems )
+import VarEnv (VarEnv, emptyVarEnv, zipVarEnv, plusVarEnv,
elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList)
-import TyCon (tyConName)
import Type (Type, tyConAppTyCon)
-import HscTypes (HomeSymbolTable, PersistentCompilerState(..),
+import HscTypes (HomePackageTable,
+ ExternalPackageState(eps_PTE), HscEnv(hsc_HPT),
TyThing(..), lookupType)
-import PrelNames (charPrimTyConName, intPrimTyConName, floatPrimTyConName,
- doublePrimTyConName, fstName, andName, orName,
- eqCharName, eqIntName, eqFloatName, eqDoubleName,
- neqCharName, neqIntName, neqFloatName, neqDoubleName,
+import PrelNames ( fstName, andName, orName,
lengthPName, replicatePName, mapPName, bpermutePName,
bpermuteDftPName, indexOfPName)
-import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps,
- bindersOfBinds)
+import TysPrim ( charPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon )
+import PrimOp ( PrimOp(..) )
+import PrelInfo ( primOpId )
+import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps)
import CoreUtils (exprType)
+import FastString (FastString)
-- friends
import NDPCoreUtils (parrElemTy)
-- initial value of the flattening state
--
-initialFlattenState :: PersistentCompilerState
- -> HomeSymbolTable
+initialFlattenState :: ExternalPackageState
+ -> HomePackageTable
-> UniqSupply
-> FlattenState
-initialFlattenState pcs hst us =
+initialFlattenState eps hpt us =
FlattenState {
us = us,
env = lookup,
}
where
lookup n =
- case lookupType hst (pcs_PTE pcs) n of
+ case lookupType hpt (eps_PTE eps) n of
Just (AnId v) -> v
_ -> pprPanic "FlattenMonad: unknown name:" (ppr n)
-- execute the given flattening computation (EXPORTED)
--
-runFlatten :: PersistentCompilerState
- -> HomeSymbolTable
+runFlatten :: HscEnv
+ -> ExternalPackageState
-> UniqSupply
-> Flatten a
-> a
-runFlatten pcs hst us m = fst $ unFlatten m (initialFlattenState pcs hst us)
+runFlatten hsc_env eps us m
+ = fst $ unFlatten m (initialFlattenState eps (hsc_HPT hsc_env) us)
-- variable generation
-- generate a new local variable whose name is based on the given lexeme and
-- whose type is as specified in the second argument (EXPORTED)
--
-newVar :: UserFS -> Type -> Flatten Var
+newVar :: FastString -> Type -> Flatten Var
newVar lexeme ty = Flatten $ \state ->
let
(us1, us2) = splitUniqSupply (us state)
-- generate a non-recursive binding using a new binder whose name is derived
-- from the given lexeme (EXPORTED)
--
-mkBind :: UserFS -> CoreExpr -> Flatten (CoreBndr, CoreBind)
+mkBind :: FastString -> CoreExpr -> Flatten (CoreBndr, CoreBind)
mkBind lexeme e =
do
v <- newVar lexeme (exprType e)
-- extend the parallel context by the given set of variables (EXPORTED)
--
--- * if there is no parallel context at the moment, the first element of the
+-- * if there is no parallel context at the moment, the first element of the
-- variable list will be used to determine the new parallel context
--
--- * the second argument is executed in the current context extended with the
+-- * the second argument is executed in the current context extended with the
-- given variables
--
--- * the variables must already have been lifted by transforming their type,
+-- * the variables must already have been lifted by transforming their type,
-- but they *must* have retained their original name (or, at least, their
-- unique); this is needed so that they match the original variable in
-- variable environments
--
--- * any trace of the given set of variables has to be removed from the state
+-- * any trace of the given set of variables has to be removed from the state
-- at the end of this operation
--
extendContext :: [Var] -> Flatten a -> Flatten a
-- execute the second argument in a restricted context (EXPORTED)
--
--- * all variables in the current parallel context are packed according to
+-- * all variables in the current parallel context are packed according to
-- the permutation vector associated with the variable passed as the first
-- argument (ie, all elements of vectorised context variables that are
-- invalid in the restricted context are dropped)
--
--- * the returned list of core binders contains the operations that perform
+-- * the returned list of core binders contains the operations that perform
-- the restriction on all variables in the parallel context that *do* occur
-- during the execution of the second argument (ie, `liftVar' is executed at
-- least once on any such variable)
(r, packedState') = unFlatten m packedState
resState = state { -- revert to the unpacked context
ctxtVar = ctxtVar state,
- ctxtEnv = ctxtEnv state,
+ ctxtEnv = ctxtEnv state
}
bndrs = map mkCoreBind . varSetElems . usedVars $ packedState'
-- generate a binding for the packed variant of a context variable
--
mkCoreBind var = let
- rhs = fst $ unFlatten (mk'bpermuteP (varType var)
+ rhs = fst $ unFlatten (mk'bpermuteP (idType var)
(Var perm)
(Var var)
) state
-- lift a single variable in the current context (EXPORTED)
--
--- * if the variable does not occur in the context, it's value is vectorised to
+-- * if the variable does not occur in the context, it's value is vectorised to
-- match the size of the current context
--
--- * otherwise, the variable is replaced by whatever the context environment
+-- * otherwise, the variable is replaced by whatever the context environment
-- maps it to (this may either be simply the lifted version of the original
-- variable or a packed variant of that variable)
--
--- * the monad keeps track of all lifted variables that occur in the parallel
+-- * the monad keeps track of all lifted variables that occur in the parallel
-- context, so that `packContext' can determine the correct set of core
-- bindings
--
liftVar var = Flatten $ \s ->
let
v = ctxtVarErr s
- v'elemType = parrElemTy . varType $ v
+ v'elemType = parrElemTy . idType $ v
len = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s
- replicated = fst $ unFlatten (mk'replicateP (varType var) len (Var var)) s
+ replicated = fst $ unFlatten (mk'replicateP (idType var) len (Var var)) s
in case lookupVarEnv (ctxtEnv s) var of
Just liftedVar -> (Var liftedVar,
s {usedVars = usedVars s `extendVarSet` var})
-- lift a constant expression in the current context (EXPORTED)
--
--- * the value of the constant expression is vectorised to match the current
+-- * the value of the constant expression is vectorised to match the current
-- parallel context
--
liftConst :: CoreExpr -> Flatten CoreExpr
liftConst e = Flatten $ \s ->
let
v = ctxtVarErr s
- v'elemType = parrElemTy . varType $ v
+ v'elemType = parrElemTy . idType $ v
len = fst $ unFlatten (mk'lengthP v'elemType (Var v)) s
in
(fst $ unFlatten (mk'replicateP (exprType e) len e ) s, s)
-- pick those variables of the given set that occur (if albeit in lifted form)
-- in the current parallel context (EXPORTED)
--
--- * the variables returned are from the given set and *not* the corresponding
+-- * the variables returned are from the given set and *not* the corresponding
-- context variables
--
intersectWithContext :: VarSet -> Flatten [Var]
-- `Double') (EXPORTED)
--
mk'eq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
-mk'eq ty a1 a2 = mkFunApp eqName [a1, a2]
+mk'eq ty a1 a2 = return (mkApps (Var eqName) [a1, a2])
where
- name = tyConName . tyConAppTyCon $ ty
+ tc = tyConAppTyCon ty
--
- eqName | name == charPrimTyConName = eqCharName
- | name == intPrimTyConName = eqIntName
- | name == floatPrimTyConName = eqFloatName
- | name == doublePrimTyConName = eqDoubleName
+ eqName | tc == charPrimTyCon = primOpId CharEqOp
+ | tc == intPrimTyCon = primOpId IntEqOp
+ | tc == floatPrimTyCon = primOpId FloatEqOp
+ | tc == doublePrimTyCon = primOpId DoubleEqOp
| otherwise =
pprPanic "FlattenMonad.mk'eq: " (ppr ty)
-- `Double') (EXPORTED)
--
mk'neq :: Type -> CoreExpr -> CoreExpr -> Flatten CoreExpr
-mk'neq ty a1 a2 = mkFunApp neqName [a1, a2]
+mk'neq ty a1 a2 = return (mkApps (Var neqName) [a1, a2])
where
- name = tyConName . tyConAppTyCon $ ty
+ tc = tyConAppTyCon ty
--
- neqName | name == charPrimTyConName = neqCharName
- | name == intPrimTyConName = neqIntName
- | name == floatPrimTyConName = neqFloatName
- | name == doublePrimTyConName = neqDoubleName
+ neqName {- | name == charPrimTyConName = neqCharName -}
+ | tc == intPrimTyCon = primOpId IntNeOp
+ {- | name == floatPrimTyConName = neqFloatName -}
+ {- | name == doublePrimTyConName = neqDoubleName -}
| otherwise =
pprPanic "FlattenMonad.mk'neq: " (ppr ty)
--
ctxtVarErr :: FlattenState -> Var
ctxtVarErr s = case ctxtVar s of
- Nothing -> panic "FlattenMonad.ctxtVarErr: No context \
- \variable available!"
+ Nothing -> panic "FlattenMonad.ctxtVarErr: No context variable available!"
Just v -> v
-- given the name of a known function and a set of arguments (needs to include
-- get the `Id' of a known `Name'
--
--- * this can be the `Name' of any function that's visible on the toplevel of
+-- * this can be the `Name' of any function that's visible on the toplevel of
-- the current compilation unit
--
lookupName :: Name -> Flatten Id
projects / ghc-hetmet.git / blobdiff