import Monad (mplus)
-- GHC
-import CmdLineOpts (opt_Flatten)
import Panic (panic)
import Outputable (Outputable(ppr), pprPanic)
import UniqSupply (UniqSupply, splitUniqSupply, uniqFromSupply)
import Var (Var(..))
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,
+import PrelNames ( fstName, andName, orName,
lengthPName, replicatePName, mapPName, bpermutePName,
bpermuteDftPName, indexOfPName)
-import PrimOp (eqCharName, eqIntName, eqFloatName, eqDoubleName,
- neqIntName)
- -- neqCharName, neqFloatName,neqDoubleName,
-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)
-- friends
-- 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
(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'
-- `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
+ | tc == intPrimTyCon = primOpId IntNeOp
{- | name == floatPrimTyConName = neqFloatName -}
{- | name == doublePrimTyConName = neqDoubleName -}
| otherwise =