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

Moved a couple of fields related to Rain type checking out of CompState and into a temporary StateT monad for the appropriate pass

Browse Source
This commit is contained in:
Neil Brown 2008-12-02 20:59:26 +00:00
parent 80c99d3bd7
commit 46a1cc311f
2 changed files with 57 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
data/CompState.hs
View File

@ -122,8 +122,6 @@ data CompState = CompState {
csPulledItems :: [[PulledItem]], csPulledItems :: [[PulledItem]],
csAdditionalArgs :: Map String [A.Actual], csAdditionalArgs :: Map String [A.Actual],
csParProcs :: Set A.Name, csParProcs :: Set A.Name,
csUnifyLookup :: Map UnifyIndex UnifyValue,
csUnifyPairs :: [(UnifyValue, UnifyValue)],
csUnifyId :: Int, csUnifyId :: Int,
csWarnings :: [WarningReport] csWarnings :: [WarningReport]
} }
@ -162,8 +160,6 @@ emptyState = CompState {
csPulledItems = [], csPulledItems = [],
csAdditionalArgs = Map.empty, csAdditionalArgs = Map.empty,
csParProcs = Set.empty, csParProcs = Set.empty,
csUnifyLookup = Map.empty,
csUnifyPairs = [],
csUnifyId = 0, csUnifyId = 0,
csWarnings = [] csWarnings = []
} }

91
frontends/RainTypes.hs
View File

@ -39,7 +39,30 @@ import TypeUnification
import UnifyType import UnifyType
import Utils import Utils
lookupMapElseMutVar :: A.TypeRequirements -> UnifyIndex -> PassM (TypeExp A.Type) data RainTypeState = RainTypeState {
csUnifyLookup :: Map.Map UnifyIndex UnifyValue,
csUnifyPairs :: [(UnifyValue, UnifyValue)]
}
startState :: RainTypeState
startState = RainTypeState {
csUnifyLookup = Map.empty,
csUnifyPairs = []
}
type RainTypeM = StateT RainTypeState PassM
type RainTypePassType = Data t => t -> StateT RainTypeState PassM t
type RainTypeCheck a = a -> RainTypeM ()
instance Die RainTypeM where
dieReport = lift . dieReport
instance CSMR RainTypeM where
getCompState = lift getCompState
lookupMapElseMutVar :: A.TypeRequirements -> UnifyIndex -> RainTypeM (TypeExp A.Type)
lookupMapElseMutVar reqs k lookupMapElseMutVar reqs k
= do st <- get = do st <- get
let m = csUnifyLookup st let m = csUnifyLookup st
@ -52,7 +75,7 @@ lookupMapElseMutVar reqs k
put st {csUnifyLookup = m'} put st {csUnifyLookup = m'}
return v return v
ttte :: Meta -> String -> (A.Type -> A.Type) -> A.Type -> PassM (TypeExp A.Type) ttte :: Meta -> String -> (A.Type -> A.Type) -> A.Type -> RainTypeM (TypeExp A.Type)
ttte m c f t = typeToTypeExp m t >>= \t' -> return $ OperType m c (\[x] -> f x) [t'] ttte m c f t = typeToTypeExp m t >>= \t' -> return $ OperType m c (\[x] -> f x) [t']
-- Transforms the given type into a typeexp, such that the only inner types -- Transforms the given type into a typeexp, such that the only inner types
@ -60,7 +83,7 @@ ttte m c f t = typeToTypeExp m t >>= \t' -> return $ OperType m c (\[x] -> f x)
-- (which would require unification of dimensions and such) are not supported, -- (which would require unification of dimensions and such) are not supported,
-- neither are records. -- neither are records.
-- User data types should not be present in the input. -- User data types should not be present in the input.
typeToTypeExp :: Meta -> A.Type -> PassM (TypeExp A.Type) typeToTypeExp :: Meta -> A.Type -> RainTypeM (TypeExp A.Type)
typeToTypeExp m (A.List t) = ttte m "[]" A.List t typeToTypeExp m (A.List t) = ttte m "[]" A.List t
typeToTypeExp m (A.Chan A.DirInput at t) = ttte m "?" (A.Chan A.DirInput at) t typeToTypeExp m (A.Chan A.DirInput at t) = ttte m "?" (A.Chan A.DirInput at) t
typeToTypeExp m (A.Chan A.DirOutput at t) = ttte m "!" (A.Chan A.DirOutput at) t typeToTypeExp m (A.Chan A.DirOutput at t) = ttte m "!" (A.Chan A.DirOutput at) t
@ -79,7 +102,7 @@ typeToTypeExp _ (A.UnknownNumLitType m id n)
return v return v
typeToTypeExp m t = return $ OperType m (show t) (const t) [] typeToTypeExp m t = return $ OperType m (show t) (const t) []
markUnify :: (ASTTypeable a, ASTTypeable b, Data a, Data b) => a -> b -> PassM () markUnify :: (ASTTypeable a, ASTTypeable b, Data a, Data b) => a -> b -> RainTypeM ()
markUnify x y markUnify x y
= do tx <- astTypeOf x = do tx <- astTypeOf x
ty <- astTypeOf y ty <- astTypeOf y
@ -92,32 +115,32 @@ performTypeUnification :: Pass
performTypeUnification = rainOnlyPass "Rain Type Checking" performTypeUnification = rainOnlyPass "Rain Type Checking"
([Prop.noInt] ++ Prop.agg_namesDone) ([Prop.noInt] ++ Prop.agg_namesDone)
[Prop.expressionTypesChecked, Prop.functionTypesChecked, Prop.processTypesChecked, Prop.retypesChecked] [Prop.expressionTypesChecked, Prop.functionTypesChecked, Prop.processTypesChecked, Prop.retypesChecked]
(\x -> do -- First, we copy the known types into the unify map: (\x -> flip evalStateT startState $ do -- First, we copy the known types into the unify map:
st <- get st <- get
ul <- shift $ csNames st ul <- getCompState >>= (shift . csNames)
put st {csUnifyPairs = [], csUnifyLookup = ul} put st {csUnifyPairs = [], csUnifyLookup = ul}
-- Then we markup all the types in the tree: -- Then we markup all the types in the tree:
x' <- markConditionalTypes x' <- (markConditionalTypes
<.< markParamPass <.< markParamPass
<.< markAssignmentTypes <.< markAssignmentTypes
<.< markCommTypes <.< markCommTypes
<.< markPoisonTypes <.< markPoisonTypes
<.< markReplicators <.< markReplicators
<.< markExpressionTypes <.< markExpressionTypes
$ x ) x
-- Then, we do the unification: -- Then, we do the unification:
prs <- get >>* csUnifyPairs prs <- get >>* csUnifyPairs
mapM_ (uncurry unifyType) prs mapM_ (lift . uncurry unifyType) prs
-- Now put the types back in a map, and replace them through the tree: -- Now put the types back in a map, and replace them through the tree:
l <- get >>* csUnifyLookup l <- get >>* csUnifyLookup
ts <- mapMapM (\v -> fromTypeExp v) l ts <- lift $ mapMapM (\v -> fromTypeExp v) l
get >>= substituteUnknownTypes ts >>= put lift $ get >>= substituteUnknownTypes ts >>= put
substituteUnknownTypes ts x') lift $ substituteUnknownTypes ts x')
where where
shift :: Map.Map String A.NameDef -> PassM (Map.Map UnifyIndex UnifyValue) shift :: Map.Map String A.NameDef -> RainTypeM (Map.Map UnifyIndex UnifyValue)
shift = liftM (Map.fromList . catMaybes) . mapM shift' . Map.toList shift = liftM (Map.fromList . catMaybes) . mapM shift' . Map.toList
where where
shift' :: (String, A.NameDef) -> PassM (Maybe (UnifyIndex, UnifyValue)) shift' :: (String, A.NameDef) -> RainTypeM (Maybe (UnifyIndex, UnifyValue))
shift' (rawName, d) = do mt <- typeOfSpec (A.ndSpecType d) shift' (rawName, d) = do mt <- typeOfSpec (A.ndSpecType d)
case mt of case mt of
Nothing -> return Nothing Nothing -> return Nothing
@ -140,10 +163,10 @@ substituteUnknownTypes mt = applyDepthM sub
Just t -> return t Just t -> return t
Nothing -> dieP m "Could not deduce type" Nothing -> dieP m "Could not deduce type"
markReplicators :: PassType markReplicators :: RainTypePassType
markReplicators = checkDepthM mark markReplicators = checkDepthM mark
where where
mark :: Check A.Specification mark :: RainTypeCheck A.Specification
mark (A.Specification _ n (A.Rep _ (A.ForEach _m e))) mark (A.Specification _ n (A.Rep _ (A.ForEach _m e)))
= astTypeOf n >>= \t -> markUnify (A.List t) e = astTypeOf n >>= \t -> markUnify (A.List t) e
mark _ = return () mark _ = return ()
@ -161,11 +184,11 @@ constantFoldPass = rainOnlyPass "Fold all constant expressions"
-- | A pass that finds all the 'A.ProcCall' and 'A.FunctionCall' in the -- | A pass that finds all the 'A.ProcCall' and 'A.FunctionCall' in the
-- AST, and checks that the actual parameters are valid inputs, given -- AST, and checks that the actual parameters are valid inputs, given
-- the 'A.Formal' parameters in the process's type -- the 'A.Formal' parameters in the process's type
markParamPass :: PassType markParamPass :: RainTypePassType
markParamPass = checkDepthM2 matchParamPassProc matchParamPassFunc markParamPass = checkDepthM2 matchParamPassProc matchParamPassFunc
where where
--Picks out the parameters of a process call, checks the number is correct, and maps doParam over them --Picks out the parameters of a process call, checks the number is correct, and maps doParam over them
matchParamPassProc :: Check A.Process matchParamPassProc :: RainTypeCheck A.Process
matchParamPassProc (A.ProcCall m n actualParams) matchParamPassProc (A.ProcCall m n actualParams)
= do def <- lookupNameOrError n $ dieP m ("Process name is unknown: \"" ++ (show $ A.nameName n) ++ "\"") = do def <- lookupNameOrError n $ dieP m ("Process name is unknown: \"" ++ (show $ A.nameName n) ++ "\"")
case A.ndSpecType def of case A.ndSpecType def of
@ -177,7 +200,7 @@ markParamPass = checkDepthM2 matchParamPassProc matchParamPassFunc
matchParamPassProc _ = return () matchParamPassProc _ = return ()
--Picks out the parameters of a function call, checks the number is correct, and maps doExpParam over them --Picks out the parameters of a function call, checks the number is correct, and maps doExpParam over them
matchParamPassFunc :: Check A.Expression matchParamPassFunc :: RainTypeCheck A.Expression
matchParamPassFunc (A.FunctionCall m n actualParams) matchParamPassFunc (A.FunctionCall m n actualParams)
= do def <- lookupNameOrError n $ dieP m ("Function name is unknown: \"" ++ (show $ A.nameName n) ++ "\"") = do def <- lookupNameOrError n $ dieP m ("Function name is unknown: \"" ++ (show $ A.nameName n) ++ "\"")
case A.ndSpecType def of case A.ndSpecType def of
@ -192,11 +215,11 @@ markParamPass = checkDepthM2 matchParamPassProc matchParamPassFunc
matchParamPassFunc _ = return () matchParamPassFunc _ = return ()
-- | Checks the types in expressions -- | Checks the types in expressions
markExpressionTypes :: PassType markExpressionTypes :: RainTypePassType
markExpressionTypes = checkDepthM checkExpression markExpressionTypes = checkDepthM checkExpression
where where
-- TODO also check in a later pass that the op is valid -- TODO also check in a later pass that the op is valid
checkExpression :: Check A.Expression checkExpression :: RainTypeCheck A.Expression
checkExpression (A.Dyadic _ _ lhs rhs) checkExpression (A.Dyadic _ _ lhs rhs)
= markUnify lhs rhs = markUnify lhs rhs
checkExpression (A.Literal _ t (A.ListLiteral _ es)) checkExpression (A.Literal _ t (A.ListLiteral _ es))
@ -212,10 +235,10 @@ markExpressionTypes = checkDepthM checkExpression
checkExpression _ = return () checkExpression _ = return ()
-- | Checks the types in assignments -- | Checks the types in assignments
markAssignmentTypes :: PassType markAssignmentTypes :: RainTypePassType
markAssignmentTypes = checkDepthM checkAssignment markAssignmentTypes = checkDepthM checkAssignment
where where
checkAssignment :: Check A.Process checkAssignment :: RainTypeCheck A.Process
checkAssignment (A.Assign m [v] (A.ExpressionList _ [e])) checkAssignment (A.Assign m [v] (A.ExpressionList _ [e]))
= do am <- abbrevModeOfVariable v = do am <- abbrevModeOfVariable v
when (am == A.ValAbbrev) $ when (am == A.ValAbbrev) $
@ -233,44 +256,44 @@ markAssignmentTypes = checkDepthM checkAssignment
checkAssignment st = return () checkAssignment st = return ()
-- | Checks the types in if and while conditionals -- | Checks the types in if and while conditionals
markConditionalTypes :: PassType markConditionalTypes :: RainTypePassType
markConditionalTypes = checkDepthM2 checkWhile checkIf markConditionalTypes = checkDepthM2 checkWhile checkIf
where where
checkWhile :: Check A.Process checkWhile :: RainTypeCheck A.Process
checkWhile w@(A.While m exp _) checkWhile w@(A.While m exp _)
= markUnify exp A.Bool = markUnify exp A.Bool
checkWhile _ = return () checkWhile _ = return ()
checkIf :: Check A.Choice checkIf :: RainTypeCheck A.Choice
checkIf c@(A.Choice m exp _) checkIf c@(A.Choice m exp _)
= markUnify exp A.Bool = markUnify exp A.Bool
-- | Marks types in poison statements -- | Marks types in poison statements
markPoisonTypes :: PassType markPoisonTypes :: RainTypePassType
markPoisonTypes = checkDepthM checkPoison markPoisonTypes = checkDepthM checkPoison
where where
checkPoison :: Check A.Process checkPoison :: RainTypeCheck A.Process
checkPoison (A.InjectPoison m ch) checkPoison (A.InjectPoison m ch)
= do u <- getUniqueIdentifer = do u <- lift getUniqueIdentifer
markUnify ch $ A.UnknownVarType (A.TypeRequirements True) $ Right (m, u) markUnify ch $ A.UnknownVarType (A.TypeRequirements True) $ Right (m, u)
checkPoison _ = return () checkPoison _ = return ()
-- | Checks the types in inputs and outputs, including inputs in alts -- | Checks the types in inputs and outputs, including inputs in alts
markCommTypes :: PassType markCommTypes :: RainTypePassType
markCommTypes = checkDepthM2 checkInputOutput checkAltInput markCommTypes = checkDepthM2 checkInputOutput checkAltInput
where where
checkInput :: A.Variable -> A.Variable -> Meta -> a -> PassM () checkInput :: A.Variable -> A.Variable -> Meta -> a -> RainTypeM ()
checkInput chanVar destVar m p checkInput chanVar destVar m p
= astTypeOf destVar >>= markUnify chanVar . A.Chan A.DirInput (A.ChanAttributes = astTypeOf destVar >>= markUnify chanVar . A.Chan A.DirInput (A.ChanAttributes
False False) False False)
checkWait :: Check A.InputMode checkWait :: RainTypeCheck A.InputMode
checkWait (A.InputTimerFor m exp) = markUnify A.Time exp checkWait (A.InputTimerFor m exp) = markUnify A.Time exp
checkWait (A.InputTimerAfter m exp) = markUnify A.Time exp checkWait (A.InputTimerAfter m exp) = markUnify A.Time exp
checkWait (A.InputTimerRead m (A.InVariable _ v)) = markUnify A.Time v checkWait (A.InputTimerRead m (A.InVariable _ v)) = markUnify A.Time v
checkWait _ = return () checkWait _ = return ()
checkInputOutput :: Check A.Process checkInputOutput :: RainTypeCheck A.Process
checkInputOutput p@(A.Input m chanVar (A.InputSimple _ [A.InVariable _ destVar])) checkInputOutput p@(A.Input m chanVar (A.InputSimple _ [A.InVariable _ destVar]))
= checkInput chanVar destVar m p = checkInput chanVar destVar m p
checkInputOutput (A.Input _ _ im@(A.InputTimerFor {})) = checkWait im checkInputOutput (A.Input _ _ im@(A.InputTimerFor {})) = checkWait im
@ -281,7 +304,7 @@ markCommTypes = checkDepthM2 checkInputOutput checkAltInput
False False) False False)
checkInputOutput _ = return () checkInputOutput _ = return ()
checkAltInput :: Check A.Alternative checkAltInput :: RainTypeCheck A.Alternative
checkAltInput a@(A.Alternative m _ chanVar (A.InputSimple _ [A.InVariable _ destVar]) body) checkAltInput a@(A.Alternative m _ chanVar (A.InputSimple _ [A.InVariable _ destVar]) body)
= checkInput chanVar destVar m a = checkInput chanVar destVar m a
checkAltInput (A.Alternative m _ _ im@(A.InputTimerFor {}) _) = checkWait im checkAltInput (A.Alternative m _ _ im@(A.InputTimerFor {}) _) = checkWait im