summaryrefslogtreecommitdiff
path: root/ghc/compiler/ndpFlatten
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/ndpFlatten')
-rw-r--r--ghc/compiler/ndpFlatten/FlattenMonad.hs42
-rw-r--r--ghc/compiler/ndpFlatten/Flattening.hs15
-rw-r--r--ghc/compiler/ndpFlatten/NDPCoreUtils.hs9
-rw-r--r--ghc/compiler/ndpFlatten/PArrAnal.hs5
4 files changed, 34 insertions, 37 deletions
diff --git a/ghc/compiler/ndpFlatten/FlattenMonad.hs b/ghc/compiler/ndpFlatten/FlattenMonad.hs
index b8a2114ac0..4bca818dd3 100644
--- a/ghc/compiler/ndpFlatten/FlattenMonad.hs
+++ b/ghc/compiler/ndpFlatten/FlattenMonad.hs
@@ -74,18 +74,16 @@ import Name (Name)
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 (HomePackageTable, PersistentCompilerState(pcs_EPS),
+import HscTypes (HomePackageTable,
ExternalPackageState(eps_PTE), HscEnv(hsc_HPT),
TyThing(..), lookupType)
-import PrelNames (charPrimTyConName, intPrimTyConName, floatPrimTyConName,
- doublePrimTyConName, fstName, andName, orName,
+import PrelNames ( fstName, andName, orName,
lengthPName, replicatePName, mapPName, bpermutePName,
bpermuteDftPName, indexOfPName)
-import PrimOp (eqCharName, eqIntName, eqFloatName, eqDoubleName,
- neqIntName)
- -- neqCharName, neqFloatName,neqDoubleName,
+import TysPrim ( charPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon )
+import PrimOp ( PrimOp(..) )
+import PrelInfo ( primOpId )
import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps)
import CoreUtils (exprType)
@@ -130,11 +128,11 @@ data FlattenState = FlattenState {
-- initial value of the flattening state
--
-initialFlattenState :: PersistentCompilerState
+initialFlattenState :: ExternalPackageState
-> HomePackageTable
-> UniqSupply
-> FlattenState
-initialFlattenState pcs hpt us =
+initialFlattenState eps hpt us =
FlattenState {
us = us,
env = lookup,
@@ -144,7 +142,7 @@ initialFlattenState pcs hpt us =
}
where
lookup n =
- case lookupType hpt (eps_PTE (pcs_EPS pcs)) n of
+ case lookupType hpt (eps_PTE eps) n of
Just (AnId v) -> v
_ -> pprPanic "FlattenMonad: unknown name:" (ppr n)
@@ -164,12 +162,12 @@ instance Monad Flatten where
-- execute the given flattening computation (EXPORTED)
--
runFlatten :: HscEnv
- -> PersistentCompilerState
+ -> ExternalPackageState
-> UniqSupply
-> Flatten a
-> a
-runFlatten hsc_env pcs us m
- = fst $ unFlatten m (initialFlattenState pcs (hsc_HPT hsc_env) us)
+runFlatten hsc_env eps us m
+ = fst $ unFlatten m (initialFlattenState eps (hsc_HPT hsc_env) us)
-- variable generation
@@ -364,14 +362,14 @@ mk'or a1 a2 = mkFunApp orName [a1, a2]
-- `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)
@@ -380,12 +378,12 @@ mk'eq ty a1 a2 = mkFunApp eqName [a1, a2]
-- `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
+ | tc == intPrimTyCon = primOpId IntNeOp
{- | name == floatPrimTyConName = neqFloatName -}
{- | name == doublePrimTyConName = neqDoubleName -}
| otherwise =
diff --git a/ghc/compiler/ndpFlatten/Flattening.hs b/ghc/compiler/ndpFlatten/Flattening.hs
index 4f0f86b53a..14b68d190d 100644
--- a/ghc/compiler/ndpFlatten/Flattening.hs
+++ b/ghc/compiler/ndpFlatten/Flattening.hs
@@ -73,8 +73,7 @@ import Var (Var(..))
import DataCon (DataCon, dataConTag)
import TypeRep (Type(..))
import Type (isTypeKind)
-import HscTypes (PersistentCompilerState, ModGuts(..),
- ModGuts, HscEnv(..) )
+import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), hscEPS )
import CoreFVs (exprFreeVars)
import CoreSyn (Expr(..), Bind(..), Alt(..), AltCon(..), Note(..),
CoreBndr, CoreExpr, CoreBind, mkLams, mkLets,
@@ -103,15 +102,15 @@ import Monad (liftM, foldM)
-- compiling a complete module (EXPORTED)
--
flatten :: HscEnv
- -> PersistentCompilerState
-> ModGuts
-> IO ModGuts
-flatten hsc_env pcs mod_impl@(ModGuts {mg_binds = binds})
+flatten hsc_env mod_impl@(ModGuts {mg_binds = binds})
| not opt_Flatten = return mod_impl -- skip without -fflatten
| otherwise =
do
let dflags = hsc_dflags hsc_env
+ eps <- hscEPS hsc_env
us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening
--
-- announce vectorisation
@@ -120,7 +119,7 @@ flatten hsc_env pcs mod_impl@(ModGuts {mg_binds = binds})
--
-- vectorise all toplevel bindings
--
- let binds' = runFlatten hsc_env pcs us $ vectoriseTopLevelBinds binds
+ let binds' = runFlatten hsc_env eps us $ vectoriseTopLevelBinds binds
--
-- and dump the result if requested
--
@@ -132,14 +131,14 @@ flatten hsc_env pcs mod_impl@(ModGuts {mg_binds = binds})
-- compiling a single expression in interactive mode (EXPORTED)
--
flattenExpr :: HscEnv
- -> PersistentCompilerState
-> CoreExpr -- the expression to be flattened
-> IO CoreExpr
-flattenExpr hsc_env pcs expr
+flattenExpr hsc_env expr
| not opt_Flatten = return expr -- skip without -fflatten
| otherwise =
do
let dflags = hsc_dflags hsc_env
+ eps <- hscEPS hsc_env
us <- mkSplitUniqSupply 'l' -- 'l' as in fLattening
--
@@ -149,7 +148,7 @@ flattenExpr hsc_env pcs expr
--
-- vectorise the expression
--
- let expr' = fst . runFlatten hsc_env pcs us $ vectorise expr
+ let expr' = fst . runFlatten hsc_env eps us $ vectorise expr
--
-- and dump the result if requested
--
diff --git a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs
index 1d221baae1..1bf74b4866 100644
--- a/ghc/compiler/ndpFlatten/NDPCoreUtils.hs
+++ b/ghc/compiler/ndpFlatten/NDPCoreUtils.hs
@@ -51,14 +51,13 @@ module NDPCoreUtils (
import Panic (panic)
import Outputable (Outputable(ppr), pprPanic)
import BasicTypes (Boxity(..))
-import Var (Var)
import Type (Type, splitTyConApp_maybe, splitFunTy)
-import TyCon (TyCon(..), isTupleTyCon)
-import PrelNames (parrTyConName)
+import TyCon (isTupleTyCon)
import TysWiredIn (parrTyCon, unitDataConId, tupleCon, intDataCon, mkPArrTy,
boolTy)
-import CoreSyn (CoreBndr, CoreExpr, CoreBind, CoreAlt, Expr(..), AltCon(..),
+import CoreSyn (CoreExpr, CoreAlt, Expr(..), AltCon(..),
Bind(..), mkConApp)
+import PprCore ( {- instances -} )
import Var (Id)
import VarEnv (IdEnv, delVarEnv, delVarEnvList, lookupVarEnv)
@@ -90,7 +89,7 @@ funTyArgs = splitFunTy
parrElemTy :: Type -> Type
parrElemTy ty =
case splitTyConApp_maybe ty of
- Just (tyCon, [argTy]) | tyConName tyCon == parrTyConName -> argTy
+ Just (tyCon, [argTy]) | tyCon == parrTyCon -> argTy
_ ->
pprPanic "NDPCoreUtils.parrElemTy: wrong type: " (ppr ty)
diff --git a/ghc/compiler/ndpFlatten/PArrAnal.hs b/ghc/compiler/ndpFlatten/PArrAnal.hs
index 0c25805d2c..46643d1a05 100644
--- a/ghc/compiler/ndpFlatten/PArrAnal.hs
+++ b/ghc/compiler/ndpFlatten/PArrAnal.hs
@@ -42,6 +42,7 @@ import TypeRep (Type(..))
import Var (Var(..),Id)
import Literal (Literal)
import CoreSyn (Expr(..),CoreExpr,Bind(..))
+import PprCore ( {- instances -} )
--
data ArrayUsage = Prim | NonPrim | Array
@@ -135,8 +136,8 @@ typeArrayUsage (TyConApp tc tcargs) =
tcargsAU = map typeArrayUsage tcargs
tcCombine = foldr combineArrayUsage Prim tcargsAU
in auCon tcCombine
-typeArrayUsage t@(SourceTy _) =
- pprPanic "PArrAnal.typeArrayUsage: encountered 'SourceType - shouldn't be here!"
+typeArrayUsage t@(PredTy _) =
+ pprPanic "PArrAnal.typeArrayUsage: encountered 'PredType - shouldn't be here!"
(ppr t)
View Lorry Controller Status