[project @ 2004-08-12 13:10:35 by simonmar]

[ghc-hetmet.git] / ghc / compiler / ndpFlatten / FlattenMonad.hs

diff --git a/ghc/compiler/ndpFlatten/FlattenMonad.hs b/ghc/compiler/ndpFlatten/FlattenMonad.hs
index 874f020..9f89563 100644 (file)
--- a/ghc/compiler/ndpFlatten/FlattenMonad.hs
+++ b/ghc/compiler/ndpFlatten/FlattenMonad.hs
@@ -64,31 +64,27 @@ module FlattenMonad (
 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,
+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
@@ -132,11 +128,11 @@ data FlattenState = FlattenState {
 
 -- 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,
@@ -146,7 +142,7 @@ initialFlattenState pcs hst us =
   }
   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)
 
@@ -165,12 +161,13 @@ instance Monad Flatten where
 
 -- 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
@@ -270,14 +267,14 @@ packContext perm m  = Flatten $ \state ->
     (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
@@ -304,9 +301,9 @@ liftVar     :: Var -> Flatten CoreExpr
 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})
@@ -321,7 +318,7 @@ 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)
@@ -365,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)
 
@@ -381,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                   =
@@ -431,8 +428,7 @@ mk'indexOfP ty a1 a2  = mkFunApp indexOfPName [Type ty, a1, a2]
 --
 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