6ab4a9923f
There's obviously some overlap with the Rain typechecker here. I've tried to cover everything in the AST that could potentially be bound into occam at some point in the future, even if the occam parser doesn't support it yet (so this'll do checks for Concat and mobile allocation, for example).
408 lines
15 KiB
Haskell
408 lines
15 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2008 University of Kent
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU General Public License as published by the
|
|
Free Software Foundation, either version 2 of the License, or (at your
|
|
option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License along
|
|
with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
-}
|
|
|
|
-- | The occam typechecker.
|
|
module OccamTypes (checkTypes) where
|
|
|
|
import Control.Monad.State
|
|
import Data.Generics
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Errors
|
|
import EvalLiterals
|
|
import Intrinsics
|
|
import Metadata
|
|
import Pass
|
|
import ShowCode
|
|
import Types
|
|
|
|
-- | A successful check.
|
|
ok :: PassM ()
|
|
ok = return ()
|
|
|
|
--{{{ type checks
|
|
|
|
-- | Are two types the same?
|
|
sameType :: A.Type -> A.Type -> PassM Bool
|
|
sameType (A.Array (A.Dimension e1 : ds1) t1)
|
|
(A.Array (A.Dimension e2 : ds2) t2)
|
|
= do n1 <- evalIntExpression e1
|
|
n2 <- evalIntExpression e2
|
|
same <- sameType (A.Array ds1 t1) (A.Array ds2 t2)
|
|
return $ (n1 == n2) && same
|
|
sameType (A.Array (A.UnknownDimension : ds1) t1)
|
|
(A.Array (A.UnknownDimension : ds2) t2)
|
|
= sameType (A.Array ds1 t1) (A.Array ds2 t2)
|
|
sameType a b = return $ a == b
|
|
|
|
-- | Check that the second dimension can be used in a context where the first
|
|
-- is expected.
|
|
isValidDimension :: A.Dimension -> A.Dimension -> PassM Bool
|
|
isValidDimension A.UnknownDimension A.UnknownDimension = return True
|
|
isValidDimension A.UnknownDimension (A.Dimension _) = return True
|
|
isValidDimension (A.Dimension e1) (A.Dimension e2)
|
|
= do n1 <- evalIntExpression e1
|
|
n2 <- evalIntExpression e2
|
|
return $ n1 == n2
|
|
isValidDimension _ _ = return False
|
|
|
|
-- | Check that the second second of dimensions can be used in a context where
|
|
-- the first is expected.
|
|
areValidDimensions :: [A.Dimension] -> [A.Dimension] -> PassM Bool
|
|
areValidDimensions [] [] = return True
|
|
areValidDimensions (d1:ds1) (d2:ds2)
|
|
= do valid <- isValidDimension d1 d2
|
|
if valid
|
|
then areValidDimensions ds1 ds2
|
|
else return False
|
|
areValidDimensions _ _ = return False
|
|
|
|
-- | Check that a type we've inferred matches the type we expected.
|
|
checkType :: Meta -> A.Type -> A.Type -> PassM ()
|
|
checkType m et rt
|
|
= case (et, rt) of
|
|
((A.Array ds t), (A.Array ds' t')) ->
|
|
do valid <- areValidDimensions ds ds'
|
|
if valid
|
|
then checkType m t t'
|
|
else bad
|
|
_ ->
|
|
do same <- sameType rt et
|
|
when (not same) $ bad
|
|
where
|
|
bad :: PassM ()
|
|
bad = diePC m $ formatCode "Type mismatch: found %, expected %" rt et
|
|
|
|
-- | Check that a type is numeric.
|
|
checkNumeric :: Meta -> A.Type -> PassM ()
|
|
checkNumeric m rawT
|
|
= do t <- underlyingType m rawT
|
|
if isIntegerType t || isRealType t
|
|
then ok
|
|
else diePC m $ formatCode "Expected numeric type; found %" t
|
|
|
|
-- | Check that a type is integral.
|
|
checkInteger :: Meta -> A.Type -> PassM ()
|
|
checkInteger m rawT
|
|
= do t <- underlyingType m rawT
|
|
if isIntegerType t
|
|
then ok
|
|
else diePC m $ formatCode "Expected integer type; found %" t
|
|
|
|
-- | Check that a type is scalar.
|
|
checkScalar :: Meta -> A.Type -> PassM ()
|
|
checkScalar m rawT
|
|
= do t <- underlyingType m rawT
|
|
if isScalarType t
|
|
then ok
|
|
else diePC m $ formatCode "Expected scalar type; found %" t
|
|
|
|
-- | Check that a type is an array.
|
|
-- (This also gets used elsewhere where we *know* the argument isn't an array,
|
|
-- so that we get a consistent error message.)
|
|
checkArray :: Meta -> A.Type -> PassM ()
|
|
checkArray m rawT
|
|
= do t <- underlyingType m rawT
|
|
case t of
|
|
(A.Array _ _) -> ok
|
|
_ -> diePC m $ formatCode "Expected array type; found %" t
|
|
|
|
-- | Check that a type is a list.
|
|
checkList :: Meta -> A.Type -> PassM ()
|
|
checkList m rawT
|
|
= do t <- underlyingType m rawT
|
|
case t of
|
|
(A.List _) -> ok
|
|
_ -> diePC m $ formatCode "Expected list type; found %" t
|
|
|
|
-- | Check the type of an expression.
|
|
checkExpressionType :: Meta -> A.Type -> A.Expression -> PassM ()
|
|
checkExpressionType m et e = typeOfExpression e >>= checkType m et
|
|
|
|
-- | Check that an expression is of integer type.
|
|
checkExpressionInt :: Meta -> A.Expression -> PassM ()
|
|
checkExpressionInt m e = checkExpressionType m A.Int e
|
|
|
|
-- | Check that an expression is of boolean type.
|
|
checkExpressionBool :: Meta -> A.Expression -> PassM ()
|
|
checkExpressionBool m e = checkExpressionType m A.Bool e
|
|
|
|
-- | Check the type of a variable.
|
|
checkVariableType :: Meta -> A.Type -> A.Variable -> PassM ()
|
|
checkVariableType m et v = typeOfVariable v >>= checkType m et
|
|
|
|
-- | Check that two lists of types match (for example, for parallel
|
|
-- assignment).
|
|
checkTypeList :: Meta -> [A.Type] -> [A.Type] -> PassM ()
|
|
checkTypeList m ets rts
|
|
= sequence_ [checkType m et rt | (et, rt) <- zip ets rts]
|
|
|
|
--}}}
|
|
--{{{ more complex checks
|
|
|
|
-- | Check that an array literal's length matches its type.
|
|
checkArraySize :: Meta -> A.Type -> Int -> PassM ()
|
|
checkArraySize m rawT want
|
|
= do t <- underlyingType m rawT
|
|
case t of
|
|
A.Array (A.UnknownDimension:_) _ -> ok
|
|
A.Array (A.Dimension e:_) _ ->
|
|
do n <- evalIntExpression e
|
|
when (n /= want) $
|
|
dieP m $ "Array literal has wrong number of elements: found " ++ show n ++ ", expected " ++ show want
|
|
_ -> checkArray m t
|
|
|
|
-- | Check that a record field name is valid.
|
|
checkRecordField :: Meta -> A.Type -> A.Name -> PassM ()
|
|
checkRecordField m t n
|
|
= do rfs <- recordFields m t
|
|
let validNames = map fst rfs
|
|
when (not $ n `elem` validNames) $
|
|
diePC m $ formatCode "Invalid field name % in record type %" n t
|
|
|
|
-- | Check that a subscript is being applied to an appropriate type.
|
|
checkSubscriptType :: Meta -> A.Subscript -> A.Type -> PassM ()
|
|
checkSubscriptType m s rawT
|
|
= do t <- underlyingType m rawT
|
|
case s of
|
|
-- A record subscript.
|
|
A.SubscriptField m n ->
|
|
checkRecordField m t n
|
|
-- An array subscript.
|
|
_ ->
|
|
case t of
|
|
A.Array _ _ -> ok
|
|
_ -> checkArray m t
|
|
|
|
-- | Classes of operators.
|
|
data OpClass = NumericOp | IntegerOp | ShiftOp | BooleanOp | ComparisonOp
|
|
| ListOp
|
|
|
|
-- | Figure out the class of a monadic operator.
|
|
classifyMOp :: A.MonadicOp -> OpClass
|
|
classifyMOp A.MonadicSubtr = NumericOp
|
|
classifyMOp A.MonadicMinus = NumericOp
|
|
classifyMOp A.MonadicBitNot = IntegerOp
|
|
classifyMOp A.MonadicNot = BooleanOp
|
|
|
|
-- | Figure out the class of a dyadic operator.
|
|
classifyOp :: A.DyadicOp -> OpClass
|
|
classifyOp A.Add = NumericOp
|
|
classifyOp A.Subtr = NumericOp
|
|
classifyOp A.Mul = NumericOp
|
|
classifyOp A.Div = NumericOp
|
|
classifyOp A.Rem = NumericOp
|
|
classifyOp A.Plus = NumericOp
|
|
classifyOp A.Minus = NumericOp
|
|
classifyOp A.Times = NumericOp
|
|
classifyOp A.BitAnd = IntegerOp
|
|
classifyOp A.BitOr = IntegerOp
|
|
classifyOp A.BitXor = IntegerOp
|
|
classifyOp A.LeftShift = ShiftOp
|
|
classifyOp A.RightShift = ShiftOp
|
|
classifyOp A.And = BooleanOp
|
|
classifyOp A.Or = BooleanOp
|
|
classifyOp A.Eq = ComparisonOp
|
|
classifyOp A.NotEq = ComparisonOp
|
|
classifyOp A.Less = ComparisonOp
|
|
classifyOp A.More = ComparisonOp
|
|
classifyOp A.LessEq = ComparisonOp
|
|
classifyOp A.MoreEq = ComparisonOp
|
|
classifyOp A.After = ComparisonOp
|
|
classifyOp A.Concat = ListOp
|
|
|
|
-- | Check a monadic operator.
|
|
checkMonadicOp :: A.MonadicOp -> A.Expression -> PassM ()
|
|
checkMonadicOp op e
|
|
= do t <- typeOfExpression e
|
|
let m = findMeta e
|
|
case classifyMOp op of
|
|
NumericOp -> checkNumeric m t
|
|
IntegerOp -> checkInteger m t
|
|
BooleanOp -> checkType m A.Bool t
|
|
|
|
-- | Check a dyadic operator.
|
|
checkDyadicOp :: A.DyadicOp -> A.Expression -> A.Expression -> PassM ()
|
|
checkDyadicOp op l r
|
|
= do lt <- typeOfExpression l
|
|
let lm = findMeta l
|
|
rt <- typeOfExpression r
|
|
let rm = findMeta r
|
|
case classifyOp op of
|
|
NumericOp ->
|
|
checkNumeric lm lt >> checkNumeric rm rt >> checkType rm lt rt
|
|
IntegerOp ->
|
|
checkInteger lm lt >> checkInteger rm rt >> checkType rm lt rt
|
|
ShiftOp ->
|
|
checkNumeric lm lt >> checkType rm A.Int rt
|
|
BooleanOp ->
|
|
checkType lm A.Bool lt >> checkType rm A.Bool rt
|
|
ComparisonOp ->
|
|
checkScalar lm lt >> checkScalar rm rt >> checkType rm lt rt
|
|
ListOp ->
|
|
checkList lm lt >> checkList rm rt >> checkType rm lt rt
|
|
|
|
-- | Check a function call.
|
|
checkFunctionCall :: Meta -> A.Name -> [A.Expression] -> Bool -> PassM ()
|
|
checkFunctionCall m n es singleOnly
|
|
= do st <- specTypeOfName n
|
|
case st of
|
|
A.Function _ _ rs fs _ ->
|
|
do when (singleOnly && length rs /= 1) $
|
|
diePC m $ formatCode "Function % used in an expression returns more than one value" n
|
|
when (length es /= length fs) $
|
|
diePC m $ formatCode ("Function % called with wrong number of arguments; found " ++ (show $ length es) ++ ", expected " ++ (show $ length fs)) n
|
|
sequence_ [do rt <- typeOfExpression e
|
|
checkType (findMeta e) et rt
|
|
| (e, A.Formal _ et _) <- zip es fs]
|
|
_ -> diePC m $ formatCode ("% is not a function; it's a " ++ show st) n
|
|
|
|
-- | Check an intrinsic function call.
|
|
checkIntrinsicFunctionCall :: Meta -> String -> [A.Expression] -> Bool
|
|
-> PassM ()
|
|
checkIntrinsicFunctionCall m s es singleOnly
|
|
= case lookup s intrinsicFunctions of
|
|
Just (rs, tns) ->
|
|
do when (singleOnly && length rs /= 1) $
|
|
dieP m $ "Intrinsic function " ++ s ++ " used in an expression returns more than one value"
|
|
when (length es /= length tns) $
|
|
dieP m $ "Intrinsic function " ++ s ++ " called with wrong number of arguments; found " ++ (show $ length es) ++ ", expected " ++ (show $ length tns)
|
|
sequence_ [do rt <- typeOfExpression e
|
|
checkType (findMeta e) et rt
|
|
| (e, (et, _)) <- zip es tns]
|
|
Nothing -> dieP m $ s ++ " is not an intrinsic function"
|
|
|
|
-- | Check a mobile allocation.
|
|
checkAllocMobile :: Meta -> A.Type -> Maybe A.Expression -> PassM ()
|
|
checkAllocMobile m rawT me
|
|
= do t <- underlyingType m rawT
|
|
case t of
|
|
A.Mobile innerT ->
|
|
do case innerT of
|
|
A.Array ds _ -> sequence_ $ map checkFullDimension ds
|
|
_ -> ok
|
|
case me of
|
|
Just e ->
|
|
do et <- typeOfExpression e
|
|
checkType (findMeta e) innerT et
|
|
Nothing -> ok
|
|
_ -> diePC m $ formatCode "Expected mobile type in allocation; found %" t
|
|
where
|
|
checkFullDimension :: A.Dimension -> PassM ()
|
|
checkFullDimension A.UnknownDimension
|
|
= dieP m $ "Type in allocation contains unknown dimensions"
|
|
checkFullDimension _ = ok
|
|
--}}}
|
|
|
|
-- | Check the AST for type consistency.
|
|
-- This is actually a series of smaller passes that check particular types
|
|
-- inside the AST, but it doesn't really make sense to split it up.
|
|
checkTypes :: Data t => t -> PassM t
|
|
checkTypes t =
|
|
checkSubscripts t >>=
|
|
checkLiterals >>=
|
|
checkVariables >>=
|
|
checkExpressions
|
|
|
|
checkSubscripts :: Data t => t -> PassM t
|
|
checkSubscripts = checkDepthM doSubscript
|
|
where
|
|
doSubscript :: A.Subscript -> PassM ()
|
|
doSubscript (A.Subscript m _ e) = checkExpressionInt m e
|
|
doSubscript (A.SubscriptFromFor m e f)
|
|
= checkExpressionInt m e >> checkExpressionInt m f
|
|
doSubscript (A.SubscriptFrom m e) = checkExpressionInt m e
|
|
doSubscript (A.SubscriptFor m e) = checkExpressionInt m e
|
|
doSubscript _ = ok
|
|
|
|
checkLiterals :: Data t => t -> PassM t
|
|
checkLiterals = checkDepthM doExpression
|
|
where
|
|
doExpression :: A.Expression -> PassM ()
|
|
doExpression (A.Literal m t lr) = doLiteralRepr t lr
|
|
doExpression _ = ok
|
|
|
|
doLiteralRepr :: A.Type -> A.LiteralRepr -> PassM ()
|
|
doLiteralRepr t (A.ArrayLiteral m aes)
|
|
= doArrayElem m t (A.ArrayElemArray aes)
|
|
doLiteralRepr t (A.RecordLiteral m es)
|
|
= do rfs <- underlyingType m t >>= recordFields m
|
|
when (length es /= length rfs) $
|
|
dieP m $ "Record literal has wrong number of fields: found " ++ (show $ length es) ++ ", expected " ++ (show $ length rfs)
|
|
sequence_ [checkExpressionType (findMeta fe) ft fe
|
|
| ((_, ft), fe) <- zip rfs es]
|
|
doLiteralRepr _ _ = ok
|
|
|
|
doArrayElem :: Meta -> A.Type -> A.ArrayElem -> PassM ()
|
|
doArrayElem m t (A.ArrayElemArray aes)
|
|
= do checkArraySize m t (length aes)
|
|
t' <- subscriptType (A.Subscript m A.NoCheck undefined) t
|
|
sequence_ $ map (doArrayElem m t') aes
|
|
doArrayElem _ t (A.ArrayElemExpr e) = checkExpressionType (findMeta e) t e
|
|
|
|
checkVariables :: Data t => t -> PassM t
|
|
checkVariables = checkDepthM doVariable
|
|
where
|
|
doVariable :: A.Variable -> PassM ()
|
|
doVariable (A.SubscriptedVariable m s v)
|
|
= do t <- typeOfVariable v
|
|
checkSubscriptType m s t
|
|
doVariable (A.DirectedVariable m _ v)
|
|
= do t <- typeOfVariable v >>= underlyingType m
|
|
case t of
|
|
A.Chan _ _ _ -> ok
|
|
_ -> dieP m $ "Direction applied to non-channel variable"
|
|
doVariable (A.DerefVariable m v)
|
|
= do t <- typeOfVariable v >>= underlyingType m
|
|
case t of
|
|
A.Mobile _ -> ok
|
|
_ -> dieP m $ "Dereference applied to non-mobile variable"
|
|
doVariable _ = ok
|
|
|
|
checkExpressions :: Data t => t -> PassM t
|
|
checkExpressions = checkDepthM doExpression
|
|
where
|
|
doExpression :: A.Expression -> PassM ()
|
|
doExpression (A.Monadic _ op e) = checkMonadicOp op e
|
|
doExpression (A.Dyadic _ op le re) = checkDyadicOp op le re
|
|
doExpression (A.MostPos m t) = checkNumeric m t
|
|
doExpression (A.MostNeg m t) = checkNumeric m t
|
|
doExpression (A.SizeType m t) = checkArray m t
|
|
doExpression (A.SizeExpr m e)
|
|
= do t <- typeOfExpression e
|
|
checkArray m t
|
|
doExpression (A.SizeVariable m v)
|
|
= do t <- typeOfVariable v
|
|
checkArray m t
|
|
doExpression (A.Conversion m _ t e)
|
|
= do et <- typeOfExpression e
|
|
checkScalar m t >> checkScalar (findMeta e) et
|
|
doExpression (A.FunctionCall m n es)
|
|
= checkFunctionCall m n es True
|
|
doExpression (A.IntrinsicFunctionCall m s es)
|
|
= checkIntrinsicFunctionCall m s es True
|
|
doExpression (A.SubscriptedExpr m s e)
|
|
= do t <- typeOfExpression e
|
|
checkSubscriptType m s t
|
|
doExpression (A.OffsetOf m rawT n)
|
|
= do t <- underlyingType m rawT
|
|
checkRecordField m t n
|
|
doExpression (A.AllocMobile m t me) = checkAllocMobile m t me
|
|
doExpression _ = ok
|