suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixed the SimplifyTypes module

Browse Source 
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.
This commit is contained in:
Neil Brown 2008-05-21 13:12:49 +00:00
parent 9f411bfd45
commit 8943b767eb
2 changed files with 36 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

27
pass/PassList.hs
View File

@ -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

30
transformations/SimplifyTypes.hs
View File

@ -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