From 8943b767eb5ff6c186d50b3be07c4de6ef7c8fd9 Mon Sep 17 00:00:00 2001
From: Neil Brown <neil@twistedsquare.com>
Date: Wed, 21 May 2008 13:12:49 +0000
Subject: [PATCH] Fixed the SimplifyTypes module

This fixes Trac ticket #46.  The pass for masking out state bodies has been moved to PassList (since it's so small and should be run first) for now, and SimplifyTypes has had its previous two passes merged into one.
---
 pass/PassList.hs                 | 27 ++++++++++++++++++++++++++-
 transformations/SimplifyTypes.hs | 30 ++++++++++--------------------
 2 files changed, 36 insertions(+), 21 deletions(-)

diff --git a/pass/PassList.hs b/pass/PassList.hs
index 5d8d3ec..8b7fb5d 100644
--- a/pass/PassList.hs
+++ b/pass/PassList.hs
@@ -20,9 +20,12 @@ with this program.  If not, see <http://www.gnu.org/licenses/>.
 module PassList (calculatePassList, getPassList) where
 
 import Control.Monad.Error
+import Control.Monad.State
 import Data.List
+import qualified Data.Map as Map
 import qualified Data.Set as Set
 
+import qualified AST as A
 import BackendPasses
 import Check
 import CompState
@@ -58,9 +61,31 @@ commonPasses opts = concat $
 filterPasses :: CompState -> [Pass] -> [Pass]
 filterPasses opts = filter (\p -> passEnabled p opts)
 
+-- This pass is so small that we may as well just give it here:
+nullStateBodies :: Pass
+nullStateBodies = Pass
+  {passCode = \t ->
+    ((get >>* \st -> st {csNames = Map.map nullProcFuncDefs (csNames st)}) >>= put)
+    >> return t
+  ,passName = "Remove process and function bodies from compiler state"
+  ,passPre = Set.empty
+  ,passPost = Set.empty
+  ,passEnabled = const True}
+  where
+    nullProcFuncDefs :: A.NameDef -> A.NameDef
+    nullProcFuncDefs (A.NameDef m n on nt (A.Proc m' sm fs _) am pl)
+      = (A.NameDef m n on nt (A.Proc m' sm fs (A.Skip m')) am pl)
+    nullProcFuncDefs (A.NameDef m n on nt (A.Function m' sm ts fs (Left _)) am pl)
+      = (A.NameDef m n on nt (A.Function m' sm ts fs (Left $ A.Several m' [])) am pl)
+    nullProcFuncDefs (A.NameDef m n on nt (A.Function m' sm ts fs (Right _)) am pl)
+      = (A.NameDef m n on nt (A.Function m' sm ts fs (Right $ A.Skip m')) am pl)
+    nullProcFuncDefs x = x
+    
+
 getPassList :: CompState -> [Pass]
 getPassList optsPS = checkList $ filterPasses optsPS $ concat
-                                [ occamPasses
+                                [ [nullStateBodies]
+                                , occamPasses
                                 , rainPasses
                                 , commonPasses optsPS
                                 , genCPasses
diff --git a/transformations/SimplifyTypes.hs b/transformations/SimplifyTypes.hs
index edb1b7c..c94d9b1 100644
--- a/transformations/SimplifyTypes.hs
+++ b/transformations/SimplifyTypes.hs
@@ -21,20 +21,24 @@ module SimplifyTypes (simplifyTypes) where
 
 import Control.Monad.State
 import Data.Generics
-import qualified Data.Map as Map
+import qualified Data.Set as Set
 
 import qualified AST as A
-import CompState
 import Metadata
 import Pass
 import qualified Properties as Prop
 import Types
 
 simplifyTypes :: [Pass]
-simplifyTypes = makePassesDep
-      [ ("Resolve types in AST", resolveNamedTypes, Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.processTypesChecked], [Prop.typesResolvedInAST])
-      , ("Resolve types in state", rntState, Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.processTypesChecked], [Prop.typesResolvedInState])
-      ]
+simplifyTypes = [resolveAllNamedTypes]
+
+resolveAllNamedTypes :: Pass
+resolveAllNamedTypes = Pass
+  {passCode = \t -> (get >>= resolveNamedTypes >>= put) >> resolveNamedTypes t
+  ,passName = "Resolve types in AST and state"
+  ,passPre = Set.fromList $ Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.processTypesChecked]
+  ,passPost = Set.fromList [Prop.typesResolvedInAST, Prop.typesResolvedInState]
+  ,passEnabled = const True}
 
 -- | Turn named data types into their underlying types.
 resolveNamedTypes :: Data t => t -> PassM t
@@ -46,17 +50,3 @@ resolveNamedTypes = doGeneric `extM` doType
     doType :: A.Type -> PassM A.Type
     doType t@(A.UserDataType _) = underlyingType emptyMeta t
     doType t = doGeneric t
-
--- | Resolve named types in CompState.
-rntState :: Data t => t -> PassM t
-rntState p = (get >>= nullBodies >>= resolveNamedTypes >>= put) >> return p
-  where
-    nullBodies :: CompState -> PassM CompState
-    nullBodies st = return $ st {csNames = Map.map nullProcFuncDefs (csNames st)}
-    
-    nullProcFuncDefs :: A.NameDef -> A.NameDef
-    nullProcFuncDefs (A.NameDef m n on nt (A.Proc m' sm fs _) am pl) = (A.NameDef m n on nt (A.Proc m' sm fs (A.Skip m')) am pl)
-    nullProcFuncDefs (A.NameDef m n on nt (A.Function m' sm ts fs (Left _)) am pl) = (A.NameDef m n on nt (A.Function m' sm ts fs (Left $ A.Several m' [])) am pl)
-    nullProcFuncDefs (A.NameDef m n on nt (A.Function m' sm ts fs (Right _)) am pl) = (A.NameDef m n on nt (A.Function m' sm ts fs (Right $ A.Skip m')) am pl)
-    nullProcFuncDefs x = x
-