8f767ff0d4
This makes sure that we catch all leftover instances of using SYB to do generic operations that we should be using Polyplate for instead. Most modules should only import Data, and possibly Typeable.
886 lines
33 KiB
Haskell
886 lines
33 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2007, 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/>.
|
|
-}
|
|
|
|
-- | Type inference and checking.
|
|
module Types
|
|
(
|
|
specTypeOfName, typeOfSpec, typeOfSpec', abbrevModeOfName, underlyingType, underlyingTypeOf, stripArrayType, abbrevModeOfVariable, abbrevModeOfSpec
|
|
, isRealType, isIntegerType, isNumericType, isCaseableType, isScalarType, isDataType, isCommunicableType, isSequenceType, isMobileType
|
|
, resolveUserType, isSafeConversion, isPreciseConversion, isImplicitConversionRain
|
|
, isOperator, functionOperator, builtInOperator, occamDefaultOperator, occamBuiltInOperatorFunctions, occamOperatorTranslateDefault
|
|
, returnTypesOfFunction
|
|
, BytesInResult(..), bytesInType, countReplicator, countStructured, computeStructured
|
|
|
|
, makeAbbrevAM, makeConstant, makeConstant', makeDimension, specificDimSize
|
|
, addOne, subOne, addExprs, subExprs, mulExprs, divExprs, remExprs
|
|
, addOneInt, subOneInt, addExprsInt, subExprsInt, mulExprsInt, divExprsInt
|
|
, dyadicExpr, dyadicExprInt
|
|
, addDimensions, applyDimension, removeFixedDimensions, trivialSubscriptType, subscriptType, unsubscriptType
|
|
, applyDirection
|
|
, recordFields, recordAttr, protocolItems, dirAttr
|
|
|
|
, leastGeneralSharedTypeRain
|
|
|
|
, ASTTypeable(..), findMeta
|
|
) where
|
|
|
|
import Control.Monad.State
|
|
import Data.Char
|
|
import Data.Generics (Data)
|
|
import qualified Data.Map as Map
|
|
import Data.Maybe
|
|
import Data.List
|
|
import Data.Ord
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified AST as A
|
|
import CompState hiding (CSM) -- all these functions are read-only!
|
|
import Errors
|
|
import EvalLiterals
|
|
import Intrinsics
|
|
import Metadata
|
|
import PrettyShow
|
|
import ShowCode
|
|
import Traversal
|
|
import TypeSizes
|
|
import Utils
|
|
|
|
class ASTTypeable a where
|
|
astTypeOf :: (CSMR m, Die m) => a -> m A.Type
|
|
|
|
instance ASTTypeable A.Type where
|
|
astTypeOf = return
|
|
|
|
underlyingTypeOf :: (ASTTypeable a, CSMR m, Die m) => Meta -> a -> m A.Type
|
|
underlyingTypeOf m = underlyingType m <.< astTypeOf
|
|
|
|
-- | Gets the 'A.AbbrevMode' for a given 'A.Name' from the recorded types in the 'CompState'. Dies with an error if the name is unknown.
|
|
abbrevModeOfName :: (CSMR m, Die m) => A.Name -> m A.AbbrevMode
|
|
abbrevModeOfName n
|
|
= liftM A.ndAbbrevMode (lookupNameOrError n $ dieP (A.nameMeta n) $ "Could not find abbreviation mode in abbrevModeOfName for: " ++ (show $ A.nameName n))
|
|
|
|
instance ASTTypeable A.Name where
|
|
astTypeOf = typeOfName
|
|
|
|
instance ASTTypeable A.Formal where
|
|
astTypeOf (A.Formal _ t _) = return t
|
|
|
|
instance ASTTypeable A.Actual where
|
|
astTypeOf (A.ActualVariable v) = astTypeOf v
|
|
astTypeOf (A.ActualExpression e) = astTypeOf e
|
|
astTypeOf (A.ActualClaim v)
|
|
= do t <- typeOfVariable v
|
|
case t of
|
|
A.Chan attr innerT -> return $ A.Chan (attr
|
|
{ A.caWritingShared = A.Unshared
|
|
, A.caReadingShared = A.Unshared
|
|
}) innerT
|
|
A.ChanEnd A.DirInput _ innerT
|
|
-> return $ A.ChanEnd A.DirInput A.Unshared innerT
|
|
A.ChanEnd A.DirOutput _ innerT
|
|
-> return $ A.ChanEnd A.DirOutput A.Unshared innerT
|
|
A.ChanDataType dir _ innerT -> return $ A.ChanDataType dir A.Unshared innerT
|
|
_ -> dieP (findMeta v) "Item in claim not channel"
|
|
astTypeOf (A.ActualChannelArray (v:vs))
|
|
= do t <- typeOfVariable v
|
|
return $ A.Array [A.Dimension $ makeConstant (findMeta v) (length vs+1)] t
|
|
|
|
|
|
-- | Gets the 'A.Type' for a given 'A.Name' by looking at its definition in the 'CompState'. Dies with an error if the name is unknown.
|
|
typeOfName :: (CSMR m, Die m) => A.Name -> m A.Type
|
|
typeOfName n
|
|
= do st <- specTypeOfName n
|
|
t <- typeOfSpec st
|
|
case t of
|
|
Just t' -> return t'
|
|
Nothing -> dieP (findMeta n) $ "cannot type name " ++ pshow n ++
|
|
":" ++ show st
|
|
|
|
typeOfSpec' :: (CSMR m, Die m) => A.SpecType -> m (Maybe (A.Type, A.Type -> A.SpecType))
|
|
typeOfSpec' st
|
|
= case st of
|
|
A.Declaration a t -> return $ Just (t, A.Declaration a)
|
|
A.Is a b t c -> return $ Just (t, \t' -> A.Is a b t' c)
|
|
A.Retypes a b t c -> return $ Just (t, \t' -> A.Retypes a b t' c)
|
|
A.RetypesExpr a b t c
|
|
-> return $ Just (t, \t' -> A.RetypesExpr a b t' c)
|
|
A.Rep _ (A.For _ _ e _) -> do t <- astTypeOf e
|
|
return $ Just (t, error "typeOfSpec'")
|
|
A.Rep _ (A.ForEach _ e) ->
|
|
do t <- astTypeOf e
|
|
case t of
|
|
A.List t' -> return $ Just (t', error "typeOfSpec'")
|
|
A.Array _ t' -> return $ Just (t', error "typeOfSpec'")
|
|
_ -> return Nothing
|
|
_ -> return Nothing
|
|
|
|
typeOfSpec :: (CSMR m, Die m) => A.SpecType -> m (Maybe A.Type)
|
|
typeOfSpec = liftM (fmap fst) . typeOfSpec'
|
|
|
|
--{{{ identifying types
|
|
-- | Get the fields of a record type.
|
|
recordFields :: (CSMR m, Die m) => Meta -> A.Type -> m [(A.Name, A.Type)]
|
|
recordFields m (A.Record rec)
|
|
= do st <- specTypeOfName rec
|
|
case st of
|
|
A.RecordType _ _ fs -> return fs
|
|
_ -> dieP m "not record type"
|
|
recordFields m (A.ChanDataType A.DirInput _ n)
|
|
= do st <- specTypeOfName n
|
|
case st of
|
|
A.ChanBundleType _ _ fs -> return fs
|
|
_ -> dieP m "not record type"
|
|
-- Directions are flipped for the ! end:
|
|
recordFields m (A.ChanDataType A.DirOutput _ n)
|
|
= do st <- specTypeOfName n
|
|
case st of
|
|
A.ChanBundleType _ _ fs -> return [(n, flipDirOfEnd t) | (n, t) <- fs]
|
|
_ -> dieP m "not record type"
|
|
where
|
|
flipDirOfEnd (A.ChanEnd dir attr t) = A.ChanEnd (flipDir dir) attr t
|
|
flipDir A.DirInput = A.DirOutput
|
|
flipDir A.DirOutput = A.DirInput
|
|
recordFields m _ = dieP m "not record type"
|
|
|
|
recordAttr :: (CSMR m, Die m) => Meta -> A.Type -> m A.RecordAttr
|
|
recordAttr m (A.Record rec)
|
|
= do st <- specTypeOfName rec
|
|
case st of
|
|
A.RecordType _ attr _ -> return attr
|
|
_ -> dieP m "not record type"
|
|
recordAttr m _ = dieP m "not record type"
|
|
|
|
dirAttr :: A.Direction -> A.ChanAttributes -> A.ShareMode
|
|
dirAttr A.DirInput = A.caReadingShared
|
|
dirAttr A.DirOutput = A.caWritingShared
|
|
|
|
-- | Get the type of a record field.
|
|
typeOfRecordField :: (CSMR m, Die m) => Meta -> A.Type -> A.Name -> m A.Type
|
|
typeOfRecordField m t field
|
|
= do fs <- recordFields m t
|
|
checkJust (Just m, "unknown record field") $ lookup field fs
|
|
|
|
-- | Apply a plain subscript to a type.
|
|
plainSubscriptType :: (CSMR m, Die m) => Meta -> A.Type -> m A.Type
|
|
plainSubscriptType m (A.Array (_:ds) t)
|
|
= return $ case ds of
|
|
[] -> t
|
|
_ -> A.Array ds t
|
|
plainSubscriptType m (A.Mobile t) = plainSubscriptType m t
|
|
plainSubscriptType m t = diePC m $ formatCode "Subscript of non-array type: %" t
|
|
|
|
-- | Turn an expression into a 'Dimension'.
|
|
-- If the expression is constant, it'll produce 'Dimension'; if not, it'll
|
|
-- produce 'UnknownDimension'.
|
|
dimensionFromExpr :: A.Expression -> A.Dimension
|
|
dimensionFromExpr e
|
|
= if isConstant e
|
|
then A.Dimension $ e
|
|
else A.UnknownDimension
|
|
|
|
-- | Apply a subscript to a type, and return what the type is after it's been
|
|
-- subscripted.
|
|
subscriptType :: (CSMR m, Die m) => A.Subscript -> A.Type -> m A.Type
|
|
subscriptType sub A.Infer
|
|
= return $ A.Infer
|
|
subscriptType sub t@(A.UserDataType _)
|
|
= resolveUserType (findMeta sub) t >>= subscriptType sub
|
|
subscriptType (A.SubscriptFromFor m _ _ count) (A.Array (_:ds) t)
|
|
= return $ A.Array (dimensionFromExpr count : ds) t
|
|
subscriptType (A.SubscriptFrom m _ base) (A.Array (d:ds) t)
|
|
= return $ A.Array (dim : ds) t
|
|
where
|
|
dim = case d of
|
|
A.Dimension size -> dimensionFromExpr $ subExprsInt size base
|
|
_ -> A.UnknownDimension
|
|
subscriptType (A.SubscriptFor m _ count) (A.Array (_:ds) t)
|
|
= return $ A.Array (dimensionFromExpr count : ds) t
|
|
subscriptType (A.SubscriptField m tag) t = typeOfRecordField m t tag
|
|
subscriptType (A.Subscript m _ _) t = plainSubscriptType m t
|
|
subscriptType sub t = diePC (findMeta sub) $ formatCode "Unsubscriptable type: %" t
|
|
|
|
-- | The inverse of 'subscriptType': given a type that we know is the result of
|
|
-- a subscript, return what the type being subscripted is.
|
|
unsubscriptType :: A.Subscript -> A.Type -> Maybe A.Type
|
|
unsubscriptType _ A.Infer
|
|
= Just $ A.Infer
|
|
unsubscriptType (A.SubscriptFromFor _ _ _ _) t
|
|
= Just $ removeFixedDimension t
|
|
unsubscriptType (A.SubscriptFrom _ _ _) t
|
|
= Just $ removeFixedDimension t
|
|
unsubscriptType (A.SubscriptFor _ _ _) t
|
|
= Just $ removeFixedDimension t
|
|
unsubscriptType (A.SubscriptField m _) t
|
|
= Nothing
|
|
unsubscriptType (A.Subscript _ _ sub) t
|
|
= Just $ addDimensions [A.UnknownDimension] t
|
|
|
|
-- | Just remove the first dimension from an array type -- like doing
|
|
-- subscriptType with constant 0 as a subscript, but without the checking.
|
|
-- This is used for the couple of cases where we know it's safe and don't want
|
|
-- the usage check.
|
|
trivialSubscriptType :: (CSMR m, Die m) => Meta -> A.Type -> m A.Type
|
|
trivialSubscriptType _ A.Infer = return A.Infer
|
|
trivialSubscriptType m t@(A.UserDataType _)
|
|
= resolveUserType m t >>= trivialSubscriptType m
|
|
trivialSubscriptType _ (A.Array [d] t) = return t
|
|
trivialSubscriptType _ (A.Array (d:ds) t) = return $ A.Array ds t
|
|
trivialSubscriptType m (A.Mobile t) = trivialSubscriptType m t
|
|
trivialSubscriptType m t = diePC m $ formatCode "not plain array type: %" t
|
|
|
|
instance ASTTypeable A.Variable where
|
|
astTypeOf = typeOfVariable
|
|
|
|
-- | Gets the 'A.Type' of a 'A.Variable' by looking at the types recorded in the 'CompState'.
|
|
typeOfVariable :: (CSMR m, Die m) => A.Variable -> m A.Type
|
|
typeOfVariable (A.Variable m n) = typeOfName n
|
|
typeOfVariable (A.SubscriptedVariable m s v)
|
|
= typeOfVariable v >>= subscriptType s
|
|
typeOfVariable (A.DerefVariable m v)
|
|
= do t <- typeOfVariable v >>= resolveUserType m
|
|
case t of
|
|
A.Mobile innerT -> return innerT
|
|
_ -> diePC m $ formatCode "Dereference applied to non-mobile variable of type %" t
|
|
typeOfVariable (A.DirectedVariable m dir v)
|
|
= do t <- typeOfVariable v
|
|
case t of
|
|
A.ChanEnd dir' _ _ ->
|
|
if dir == dir'
|
|
then return t
|
|
else dieP m $ "Attempted to reverse direction of a channel-end"
|
|
A.Chan attr innerT -> return $ A.ChanEnd dir (dirAttr dir attr) innerT
|
|
A.Array ds (A.Chan attr innerT)
|
|
-> return $ A.Array ds (A.ChanEnd dir (dirAttr dir attr) innerT)
|
|
A.Array _ (A.ChanEnd dir' _ _) ->
|
|
if dir == dir'
|
|
then return t
|
|
else dieP m $ "Attempted to reverse direction of a channel-end"
|
|
A.Infer -> return $ A.ChanEnd dir A.Unshared A.Infer
|
|
_ -> diePC m $ formatCode "Direction specified on non-channel variable of type: %" t
|
|
typeOfVariable (A.VariableSizes m v)
|
|
= do t <- typeOfVariable v
|
|
case t of
|
|
A.Array ds _ -> return $ A.Array [A.Dimension $ makeConstant m $ length ds] A.Int
|
|
A.Mobile (A.Array ds _) -> return $ A.Array [A.Dimension $ makeConstant m $ length ds] A.Int
|
|
_ -> diePC m $ formatCode "Attempted to get size of non-array: % (type: %)" v t
|
|
|
|
-- | Get the abbreviation mode of a variable.
|
|
abbrevModeOfVariable :: (CSMR m, Die m) => A.Variable -> m A.AbbrevMode
|
|
abbrevModeOfVariable (A.Variable _ n) = abbrevModeOfName n
|
|
abbrevModeOfVariable (A.SubscriptedVariable _ sub v) = abbrevModeOfVariable v
|
|
abbrevModeOfVariable (A.DirectedVariable _ _ v) = abbrevModeOfVariable v
|
|
abbrevModeOfVariable (A.DerefVariable _ v) = return A.Original
|
|
abbrevModeOfVariable (A.VariableSizes {}) = return A.Original
|
|
|
|
instance ASTTypeable A.Expression where
|
|
astTypeOf = typeOfExpression
|
|
|
|
-- | Gets the 'A.Type' of an 'A.Expression'. This function assumes that the expression has already been type-checked.
|
|
typeOfExpression :: (CSMR m, Die m) => A.Expression -> m A.Type
|
|
typeOfExpression e
|
|
= case e of
|
|
A.MostPos m t -> return t
|
|
A.MostNeg m t -> return t
|
|
A.SizeType m t -> return A.Int
|
|
A.SizeExpr m t -> return A.Int
|
|
A.Conversion m cm t e -> return t
|
|
A.ExprVariable m v -> typeOfVariable v
|
|
A.Literal _ t _ -> return t
|
|
A.True m -> return A.Bool
|
|
A.False m -> return A.Bool
|
|
A.FunctionCall m n es -> liftM head $ returnTypesOfFunction n
|
|
A.IntrinsicFunctionCall m s _ -> liftM head $ returnTypesOfIntrinsic m s
|
|
A.SubscriptedExpr m s e ->
|
|
typeOfExpression e >>= subscriptType s
|
|
A.BytesInExpr m e -> return A.Int
|
|
A.BytesInType m t -> return A.Int
|
|
A.OffsetOf m t n -> return A.Int
|
|
A.AllocMobile _ t _ -> return t
|
|
A.CloneMobile _ e -> typeOfExpression e
|
|
A.IsDefined {} -> return A.Bool
|
|
--}}}
|
|
|
|
-- | Gets the return type(s) of a function call from the 'CompState'.
|
|
returnTypesOfFunction :: (CSMR m, Die m) => A.Name -> m [A.Type]
|
|
returnTypesOfFunction n
|
|
= do st <- specTypeOfName n
|
|
case st of
|
|
A.Function _ _ rs _ _ -> return rs
|
|
-- If it's not defined as a function, it might have been converted to a proc.
|
|
_ ->
|
|
do ps <- getCompState
|
|
checkJust (Just $ findMeta n, "not defined as a function") $
|
|
Map.lookup (A.nameName n) (csFunctionReturns ps)
|
|
|
|
returnTypesOfIntrinsic :: (CSMR m, Die m) => Meta -> String -> m [A.Type]
|
|
returnTypesOfIntrinsic m s
|
|
= do frontend <- getCompState >>* csFrontend
|
|
let intrinsicList = case frontend of
|
|
FrontendOccam -> intrinsicFunctions
|
|
FrontendRain -> rainIntrinsicFunctions
|
|
case lookup s intrinsicList of
|
|
Just (rts, _) -> return rts
|
|
Nothing -> dieP m $ "unknown intrinsic function " ++ s
|
|
|
|
-- | Get the items in a channel's protocol (for typechecking).
|
|
-- Returns Left if it's a simple protocol, Right if it's tagged.
|
|
protocolItems :: (ASTTypeable a, Data a, CSMR m, Die m) => Meta -> a -> m (Either [A.Type] [(A.Name, [A.Type])])
|
|
protocolItems m v
|
|
= do chanT <- astTypeOf v
|
|
t <- case chanT of
|
|
A.Chan _ t -> return t
|
|
A.ChanEnd _ _ t -> return t
|
|
_ -> dieP m $ "Expected a channel variable, but this is of type: " ++ show chanT
|
|
case t of
|
|
A.UserProtocol proto ->
|
|
do st <- specTypeOfName proto
|
|
case st of
|
|
A.Protocol _ ts -> return $ Left ts
|
|
A.ProtocolCase _ nts -> return $ Right nts
|
|
_ -> return $ Left [t]
|
|
|
|
-- | Gets the 'A.AbrrevMode' of a 'A.SpecType' directly.
|
|
abbrevModeOfSpec :: A.SpecType -> A.AbbrevMode
|
|
abbrevModeOfSpec s
|
|
= case s of
|
|
A.Is _ am _ _ -> am
|
|
A.Retypes _ am _ _ -> am
|
|
A.RetypesExpr _ am _ _ -> am
|
|
_ -> A.Original
|
|
|
|
-- | Add array dimensions to a type; if it's already an array it'll just add
|
|
-- the new dimensions to the existing array.
|
|
addDimensions :: [A.Dimension] -> A.Type -> A.Type
|
|
addDimensions newDs (A.Array ds t) = A.Array (newDs ++ ds) t
|
|
addDimensions ds t = A.Array ds t
|
|
|
|
-- | Set the first dimension of an array type.
|
|
applyDimension :: A.Dimension -> A.Type -> A.Type
|
|
applyDimension dim (A.Array (_:ds) t) = A.Array (dim : ds) t
|
|
applyDimension _ t = t
|
|
|
|
-- | Return a type with any enclosing arrays removed; useful for identifying
|
|
-- things that should be channel names, timer names, etc. in the parser.
|
|
stripArrayType :: A.Type -> A.Type
|
|
stripArrayType (A.Array _ t) = stripArrayType t
|
|
stripArrayType t = t
|
|
|
|
-- | Remove one fixed dimension from a type.
|
|
removeFixedDimension :: A.Type -> A.Type
|
|
removeFixedDimension (A.Array (A.Dimension _:ds) t) = A.Array (A.UnknownDimension:ds) t
|
|
removeFixedDimension t = t
|
|
|
|
-- | Remove any fixed array dimensions from a type.
|
|
removeFixedDimensions :: A.Type -> A.Type
|
|
removeFixedDimensions (A.Array ds t) = A.Array [A.UnknownDimension | _ <- ds] t
|
|
removeFixedDimensions t = t
|
|
|
|
-- | Given the abbreviation mode of something, return what the abbreviation
|
|
-- mode of something that abbreviated it would be.
|
|
makeAbbrevAM :: A.AbbrevMode -> A.AbbrevMode
|
|
makeAbbrevAM A.Original = A.Abbrev
|
|
makeAbbrevAM am = am
|
|
|
|
-- | Generate a constant expression from an integer -- for array sizes and the
|
|
-- like.
|
|
makeConstant :: Meta -> Int -> A.Expression
|
|
makeConstant m = makeConstant' m A.Int . toInteger
|
|
|
|
makeConstant' :: Meta -> A.Type -> Integer -> A.Expression
|
|
makeConstant' m t n = A.Literal m t $ A.IntLiteral m (show n)
|
|
|
|
-- | Generate a constant dimension from an integer.
|
|
makeDimension :: Meta -> Int -> A.Dimension
|
|
makeDimension m n = A.Dimension $ makeConstant m n
|
|
|
|
-- | Apply a direction to a type.
|
|
applyDirection :: Die m => Meta -> A.Direction -> A.Type -> m A.Type
|
|
applyDirection m dir (A.Array ds t)
|
|
= applyDirection m dir t >>* A.Array ds
|
|
applyDirection m dir (A.Chan ca t)
|
|
= return $ A.ChanEnd dir (dirAttr dir ca) t
|
|
applyDirection m _ t
|
|
= dieP m "Direction specified on non-channel type"
|
|
|
|
-- | Checks whether a given conversion can be done implicitly in Rain
|
|
-- Parameters are src dest
|
|
isImplicitConversionRain :: A.Type -> A.Type -> Bool
|
|
isImplicitConversionRain x y
|
|
= if (x == y)
|
|
then True
|
|
else if (x == A.Bool || y == A.Bool)
|
|
then False
|
|
else isSafeConversion x y
|
|
|
|
-- | Is a conversion between two types precise (i.e. do you need to specify
|
|
-- ROUND or TRUNC when doing it)?
|
|
isPreciseConversion :: A.Type -> A.Type -> Bool
|
|
isPreciseConversion A.Real32 A.Real64 = True
|
|
isPreciseConversion fromT toT
|
|
= fromT == toT || not (isRealType fromT || isRealType toT)
|
|
|
|
-- | Will a conversion between two types always succeed?
|
|
--Parameters are src dest
|
|
isSafeConversion :: A.Type -> A.Type -> Bool
|
|
isSafeConversion A.Real32 A.Real64 = True
|
|
isSafeConversion src dest = (src' == dest') || ((src' == A.Bool || isIntegerType src') && (dest' == A.Bool || isIntegerType dest') && (findCastRoute dest' src'))
|
|
where
|
|
src' = convInt src
|
|
dest' = convInt dest
|
|
|
|
--Turn Int into Int32:
|
|
convInt :: A.Type -> A.Type
|
|
convInt A.Int = A.Int32
|
|
convInt t = t
|
|
|
|
--Parameters are dest src
|
|
findCastRoute :: A.Type -> A.Type -> Bool
|
|
findCastRoute dest src
|
|
--Either a direct converstion is possible
|
|
= (elem (dest,src) possibleConversions)
|
|
--Or there exists some chained conversion:
|
|
|| (any (findCastRoute dest) (findDests src possibleConversions))
|
|
|
|
--Finds all the conversions from the src type using the given list of (dest,src)
|
|
--Note that the list must not allow any cycles! (or else we will engage in infinite recursion)
|
|
findDests :: A.Type -> [(A.Type,A.Type)] -> [A.Type]
|
|
findDests _ [] = []
|
|
findDests src ((dest,src'):ts) = if src == src' then dest : (findDests src ts) else findDests src ts
|
|
|
|
--Listed in order (dest, src)
|
|
--Signed numbers cannot be safely cast to unsigned numbers. So (A.UInt16, A.Int8) isn't possible
|
|
possibleConversions :: [(A.Type,A.Type)]
|
|
possibleConversions
|
|
= [
|
|
(A.Byte, A.Bool)
|
|
,(A.Int8, A.Bool)
|
|
|
|
,(A.Int16, A.Int8)
|
|
,(A.Int16, A.Byte)
|
|
,(A.Int32, A.Int16)
|
|
,(A.Int32, A.UInt16)
|
|
,(A.Int64, A.Int32)
|
|
,(A.Int64, A.UInt32)
|
|
|
|
,(A.UInt16, A.Byte)
|
|
,(A.UInt32, A.UInt16)
|
|
,(A.UInt64, A.UInt32)
|
|
]
|
|
|
|
|
|
-- | Works out the least-general type that all given types can be upcast to. Does not work with A.Int (as this function is expected only to be used by Rain)
|
|
-- As you would expect from the name, this function specifically follows the conversion rules for Rain.
|
|
leastGeneralSharedTypeRain :: [A.Type] -> Maybe A.Type
|
|
leastGeneralSharedTypeRain [] = Nothing
|
|
leastGeneralSharedTypeRain [t] = Just t
|
|
leastGeneralSharedTypeRain list@(t:ts)
|
|
= if (all ((==) t) ts) then Just t else
|
|
if (all isIntegerType list) then findInt list
|
|
else Nothing
|
|
where
|
|
findInt :: [A.Type] -> Maybe A.Type
|
|
findInt list = if null candidates
|
|
then Nothing
|
|
else Just $ snd $ maximumBy (comparing fst) candidates
|
|
where
|
|
candidates = if (all unsignedInt list) then (zip (map intSize list) list) else (allJustElseEmpty $ map findIntSigned list)
|
|
|
|
signedInt :: A.Type -> Bool
|
|
signedInt = not . unsignedInt
|
|
|
|
unsignedInt :: A.Type -> Bool
|
|
unsignedInt A.Byte = True
|
|
unsignedInt A.UInt16 = True
|
|
unsignedInt A.UInt32 = True
|
|
unsignedInt A.UInt64 = True
|
|
unsignedInt _ = False
|
|
|
|
intSize :: A.Type -> Int
|
|
intSize A.Byte = 1
|
|
intSize A.UInt16 = 2
|
|
intSize A.UInt32 = 4
|
|
intSize A.UInt64 = 8
|
|
intSize A.Int8 = 1
|
|
intSize A.Int16 = 2
|
|
intSize A.Int32 = 4
|
|
intSize A.Int64 = 8
|
|
intSize _ = 0 --should never happen
|
|
|
|
--If all the items in the list are Just x, returns a list of them all.
|
|
--If one (or more items) is Nothing, returns an empty list.
|
|
allJustElseEmpty :: [Maybe a] -> [a]
|
|
allJustElseEmpty ms = if (any isNothing ms) then [] else catMaybes ms
|
|
|
|
--For each item in the list, get an ordered list of types we can cast to.
|
|
findIntSigned :: A.Type -> Maybe (Int,A.Type)
|
|
findIntSigned t = if (signedInt t)
|
|
then Just (intSize t,t)
|
|
--if it's unsigned, we need to cast it up by one type, assuming it's not already the biggest size
|
|
else transformMaybe (\x -> (intSize x,x)) (case t of
|
|
A.Byte -> Just A.Int16
|
|
A.UInt16 -> Just A.Int32
|
|
A.UInt32 -> Just A.Int64
|
|
A.UInt64 -> Nothing)
|
|
|
|
--{{{ classes of types
|
|
-- | Scalar integer types.
|
|
isIntegerType :: A.Type -> Bool
|
|
isIntegerType t
|
|
= case t of
|
|
A.Byte -> True
|
|
A.UInt16 -> True
|
|
A.UInt32 -> True
|
|
A.UInt64 -> True
|
|
A.Int8 -> True
|
|
A.Int -> True
|
|
A.Int16 -> True
|
|
A.Int32 -> True
|
|
A.Int64 -> True
|
|
A.Time -> True
|
|
_ -> False
|
|
|
|
-- | Scalar real types.
|
|
isRealType :: A.Type -> Bool
|
|
isRealType t
|
|
= case t of
|
|
A.Real32 -> True
|
|
A.Real64 -> True
|
|
_ -> False
|
|
|
|
-- | Numeric types.
|
|
isNumericType :: A.Type -> Bool
|
|
isNumericType t = isIntegerType t || isRealType t
|
|
|
|
-- | Types that are permitted as 'Case' selectors.
|
|
isCaseableType :: A.Type -> Bool
|
|
isCaseableType A.Bool = True
|
|
isCaseableType t = isIntegerType t
|
|
|
|
-- | All scalar types.
|
|
isScalarType :: A.Type -> Bool
|
|
isScalarType A.Bool = True
|
|
isScalarType t = isIntegerType t || isRealType t
|
|
|
|
-- | Types that can be used to define 'DataType's.
|
|
isDataType :: A.Type -> Bool
|
|
-- This may change in the future.
|
|
isDataType = isCommunicableType
|
|
|
|
-- | Types that can be communicated across a channel.
|
|
isCommunicableType :: A.Type -> Bool
|
|
isCommunicableType (A.Array _ t) = isCommunicableType t
|
|
isCommunicableType (A.List t) = isCommunicableType t
|
|
isCommunicableType (A.Record _) = True
|
|
isCommunicableType (A.Mobile _) = True
|
|
isCommunicableType t = isScalarType t
|
|
|
|
-- | Types that support 'Size' and subscripting.
|
|
isSequenceType :: Bool -> A.Type -> Bool
|
|
isSequenceType _ (A.Array _ _) = True
|
|
isSequenceType _ (A.List _) = True
|
|
isSequenceType True (A.Mobile t) = isSequenceType False t
|
|
isSequenceType _ _ = False
|
|
|
|
isMobileType :: (CSMR m, Die m) => A.Type -> m Bool
|
|
isMobileType (A.Mobile {}) = return True
|
|
isMobileType t@(A.Record n) = recordAttr (A.nameMeta n) t >>* A.mobileRecord
|
|
isMobileType (A.ChanDataType {}) = return True
|
|
isMobileType _ = return False
|
|
|
|
--}}}
|
|
|
|
--{{{ sizes of types
|
|
-- | The size in bytes of a data type.
|
|
data BytesInResult =
|
|
BIJust A.Expression -- ^ Just that many bytes.
|
|
| BIOneFree A.Expression Int -- ^ An array type; A bytes, times unknown dimension B.
|
|
| BIManyFree -- ^ An array type with multiple unknown dimensions.
|
|
| BIUnknown -- ^ We can't tell the size at compile time.
|
|
deriving (Show, Eq)
|
|
|
|
-- | Make a fixed-size 'BytesInResult'.
|
|
justSize :: CSMR m => Int -> m BytesInResult
|
|
justSize n = return $ BIJust $ makeConstant emptyMeta n
|
|
|
|
-- | Given the C and C++ values (in that order), selects according to the
|
|
-- backend. If the backend is not recognised, the C sizes are used.
|
|
justSizeBackends :: CSMR m => Int -> Int -> m BytesInResult
|
|
justSizeBackends c cxx
|
|
= do backend <- getCompState >>* csBackend
|
|
case backend of
|
|
BackendCPPCSP -> justSize c
|
|
_ -> justSize cxx
|
|
|
|
-- | Return the size in bytes of a data type.
|
|
bytesInType :: (CSMR m, Die m) => A.Type -> m BytesInResult
|
|
bytesInType A.Bool = justSizeBackends cBoolSize cxxBoolSize
|
|
bytesInType A.Byte = justSize 1
|
|
bytesInType A.UInt16 = justSize 2
|
|
bytesInType A.UInt32 = justSize 4
|
|
bytesInType A.UInt64 = justSize 8
|
|
bytesInType A.Int8 = justSize 1
|
|
bytesInType A.Int = justSizeBackends cIntSize cxxIntSize
|
|
bytesInType A.Int16 = justSize 2
|
|
bytesInType A.Int32 = justSize 4
|
|
bytesInType A.Int64 = justSize 8
|
|
bytesInType A.Real32 = justSize 4
|
|
bytesInType A.Real64 = justSize 8
|
|
bytesInType a@(A.Array _ _) = bytesInArray 0 a
|
|
where
|
|
bytesInArray :: (CSMR m, Die m) => Int -> A.Type -> m BytesInResult
|
|
bytesInArray num (A.Array [] t) = bytesInType t
|
|
bytesInArray num (A.Array (d:ds) t)
|
|
= do ts <- bytesInArray (num + 1) (A.Array ds t)
|
|
case (d, ts) of
|
|
(A.Dimension n, BIJust m) -> return $ BIJust (mulExprsInt n m)
|
|
(A.Dimension n, BIOneFree m x) -> return $ BIOneFree (mulExprsInt n m) x
|
|
(A.UnknownDimension, BIJust m) -> return $ BIOneFree m num
|
|
(A.UnknownDimension, BIOneFree _ _) -> return BIManyFree
|
|
(_, _) -> return ts
|
|
bytesInType (A.Record n)
|
|
= do st <- specTypeOfName n
|
|
case st of
|
|
-- We can only do this for *packed* records -- for normal records,
|
|
-- the compiler might insert padding.
|
|
(A.RecordType _ (A.RecordAttr {A.packedRecord=True}) nts) -> bytesInList nts
|
|
_ -> return $ BIUnknown
|
|
where
|
|
bytesInList :: (CSMR m, Die m) => [(A.Name, A.Type)] -> m BytesInResult
|
|
bytesInList [] = justSize 0
|
|
bytesInList ((_, t):rest)
|
|
= do bi <- bytesInType t
|
|
br <- bytesInList rest
|
|
case (bi, br) of
|
|
(BIJust a, BIJust b) -> return $ BIJust (addExprsInt a b)
|
|
(_, _) -> return BIUnknown
|
|
bytesInType _ = return $ BIUnknown
|
|
--}}}
|
|
|
|
-- | Get the number of items a replicator produces.
|
|
countReplicator :: A.Replicator -> A.Expression
|
|
countReplicator (A.For _ _ count _) = count
|
|
|
|
-- | Get the number of items in a Structured as an expression.
|
|
countStructured :: Data a => A.Structured a -> A.Expression
|
|
countStructured = computeStructured (\m _ -> makeConstant m 1)
|
|
|
|
-- | Compute an expression over a Structured.
|
|
computeStructured :: Data a => (Meta -> a -> A.Expression) -> A.Structured a -> A.Expression
|
|
computeStructured f (A.Spec _ (A.Specification _ _ (A.Rep m rep)) s)
|
|
= mulExprsInt (countReplicator rep) (computeStructured f s)
|
|
computeStructured f (A.Spec _ _ s) = computeStructured f s
|
|
computeStructured f (A.ProcThen _ _ s) = computeStructured f s
|
|
computeStructured f (A.Only m x) = f m x
|
|
computeStructured f (A.Several m ss)
|
|
= case ss of
|
|
[] -> makeConstant m 0
|
|
_ -> foldl1 addExprsInt (map (computeStructured f) ss)
|
|
|
|
specificDimSize :: Int -> A.Variable -> A.Variable
|
|
specificDimSize n v = A.SubscriptedVariable (findMeta v) (A.Subscript (findMeta v) A.NoCheck
|
|
$ makeConstant (findMeta v) n) $ A.VariableSizes (findMeta v) v
|
|
|
|
|
|
functionOperator :: (CSMR m, Die m) => A.Name -> m (Maybe String)
|
|
functionOperator n
|
|
= lookupNameOrError n (dieP (A.nameMeta n) $ "Can't find operator definition for " ++ A.nameName n)
|
|
>>* A.ndOrigName
|
|
>>* (\op -> if isOperator op then Just op else Nothing)
|
|
|
|
-- Only gives back a Just result if it's a non-overridden operator
|
|
builtInOperator :: (CSMR m, Die m) => A.Name -> m (Maybe String)
|
|
builtInOperator n
|
|
= do mOp <- functionOperator n
|
|
return $ case mOp of
|
|
Nothing -> Nothing
|
|
Just op
|
|
| A.nameName n `Set.member` occamBuiltInOperatorFunctionsSet
|
|
-> Just op
|
|
| otherwise
|
|
-> Nothing
|
|
|
|
isOperator :: String -> Bool
|
|
isOperator op = any (== op) operatorNames
|
|
|
|
operatorNames :: [String]
|
|
operatorNames =
|
|
["??"
|
|
,"@@"
|
|
,"$$"
|
|
,"%"
|
|
,"%%"
|
|
,"&&"
|
|
,"<%"
|
|
,"%>"
|
|
,"<&"
|
|
,"&>"
|
|
,"<]"
|
|
,"[>"
|
|
,"<@"
|
|
,"@>"
|
|
,"@"
|
|
,"++"
|
|
,"!!"
|
|
,"=="
|
|
,"^"
|
|
,"-"
|
|
,"MINUS"
|
|
,"~"
|
|
,"NOT"
|
|
,"+"
|
|
,"*"
|
|
,"/"
|
|
,"\\"
|
|
,"REM"
|
|
,"PLUS"
|
|
,"TIMES"
|
|
,"AFTER"
|
|
,"/\\"
|
|
,"\\/"
|
|
,"><"
|
|
,"BITNOT"
|
|
,"BITAND"
|
|
,"BITOR"
|
|
,"<<"
|
|
,">>"
|
|
,"AND"
|
|
,"OR"
|
|
,"="
|
|
,"<>"
|
|
,"<="
|
|
,"<"
|
|
,">="
|
|
,">"
|
|
]
|
|
|
|
-- | This gives a default mapping from operator (such as "+") to a valid name string
|
|
-- to be used in the backend (i.e. the Tock support headers), such as "add", which
|
|
-- will later be suffixed by the types in question.
|
|
occamOperatorTranslateDefault :: String -> String
|
|
occamOperatorTranslateDefault "+" = "add"
|
|
occamOperatorTranslateDefault "-" = "subtr"
|
|
occamOperatorTranslateDefault "*" = "mul"
|
|
occamOperatorTranslateDefault "/" = "div"
|
|
occamOperatorTranslateDefault "TIMES" = "times"
|
|
occamOperatorTranslateDefault "PLUS" = "plus"
|
|
occamOperatorTranslateDefault "MINUS" = "minus"
|
|
occamOperatorTranslateDefault "AFTER" = "after"
|
|
occamOperatorTranslateDefault ">" = "more"
|
|
occamOperatorTranslateDefault "<" = "less"
|
|
occamOperatorTranslateDefault ">=" = "moreEq"
|
|
occamOperatorTranslateDefault "<=" = "lessEq"
|
|
occamOperatorTranslateDefault "=" = "eq"
|
|
occamOperatorTranslateDefault "<>" = "notEq"
|
|
occamOperatorTranslateDefault "\\" = "rem"
|
|
occamOperatorTranslateDefault "REM" = "REM"
|
|
occamOperatorTranslateDefault "/\\" = "and"
|
|
occamOperatorTranslateDefault "\\/" = "or"
|
|
occamOperatorTranslateDefault "><" = "xor"
|
|
occamOperatorTranslateDefault "<<" = "lshift"
|
|
occamOperatorTranslateDefault ">>" = "rshift"
|
|
occamOperatorTranslateDefault "AND" = "and"
|
|
occamOperatorTranslateDefault "OR" = "or"
|
|
occamOperatorTranslateDefault "NOT" = "not"
|
|
occamOperatorTranslateDefault "~" = "not"
|
|
occamOperatorTranslateDefault cs = "op_" ++ concatMap (show . ord) cs
|
|
|
|
occamDefaultOperator :: String -> [A.Type] -> String
|
|
occamDefaultOperator op ts = "occam_" ++ occamOperatorTranslateDefault op
|
|
++ concatMap (('_':) . showOccam) ts
|
|
|
|
occamBuiltInOperatorFunctions :: [String]
|
|
occamBuiltInOperatorFunctions
|
|
= [occamDefaultOperator n ts
|
|
| (n, _, ts) <- occamIntrinsicOperators]
|
|
|
|
occamBuiltInOperatorFunctionsSet :: Set.Set String
|
|
occamBuiltInOperatorFunctionsSet = Set.fromList occamBuiltInOperatorFunctions
|
|
|
|
-- | Add one to an expression.
|
|
addOne :: (CSMR m, Die m) => A.Expression -> m A.Expression
|
|
addOne e = addExprs (makeConstant m 1) e
|
|
where m = findMeta e
|
|
|
|
-- | Subtrace one from an expression.
|
|
subOne :: (CSMR m, Die m) => A.Expression -> m A.Expression
|
|
subOne e = subExprs e (makeConstant m 1)
|
|
where m = findMeta e
|
|
|
|
-- | Add one to an expression.
|
|
addOneInt :: A.Expression -> A.Expression
|
|
addOneInt e = addExprsInt (makeConstant m 1) e
|
|
where m = findMeta e
|
|
|
|
-- | Subtrace one from an expression.
|
|
subOneInt :: A.Expression -> A.Expression
|
|
subOneInt e = subExprsInt e (makeConstant m 1)
|
|
where m = findMeta e
|
|
|
|
type DyadicExpr = A.Expression -> A.Expression -> A.Expression
|
|
type DyadicExprM = (CSMR m, Die m) => A.Expression -> A.Expression -> m A.Expression
|
|
|
|
dyadicExpr' :: (A.Type, A.Type) -> String -> DyadicExpr
|
|
dyadicExpr' (t0, t1) op a b
|
|
= A.FunctionCall m (A.Name m $ occamDefaultOperator op [t0,t1]) [a, b]
|
|
where
|
|
m = findMeta a
|
|
|
|
dyadicExpr :: String -> DyadicExprM
|
|
dyadicExpr op a b = do ta <- astTypeOf a
|
|
tb <- astTypeOf b
|
|
return $ dyadicExpr' (ta, tb) op a b
|
|
|
|
dyadicExprInt :: String -> DyadicExpr
|
|
dyadicExprInt op = dyadicExpr' (A.Int, A.Int) op
|
|
|
|
-- | Add two expressions.
|
|
addExprs :: DyadicExprM
|
|
addExprs = dyadicExpr "+"
|
|
|
|
-- | Add two expressions.
|
|
subExprs :: DyadicExprM
|
|
subExprs = dyadicExpr "-"
|
|
|
|
-- | Multiply two expressions.
|
|
mulExprs :: DyadicExprM
|
|
mulExprs = dyadicExpr "*"
|
|
|
|
-- | Divide two expressions.
|
|
divExprs :: DyadicExprM
|
|
divExprs = dyadicExpr "/"
|
|
|
|
-- | Divide two expressions.
|
|
remExprs :: DyadicExprM
|
|
remExprs = dyadicExpr "\\"
|
|
|
|
-- | Add two expressions.
|
|
addExprsInt :: DyadicExpr
|
|
addExprsInt = dyadicExpr' (A.Int,A.Int) "+"
|
|
|
|
-- | Add two expressions.
|
|
subExprsInt :: DyadicExpr
|
|
subExprsInt = dyadicExpr' (A.Int,A.Int) "-"
|
|
|
|
-- | Multiply two expressions.
|
|
mulExprsInt :: DyadicExpr
|
|
mulExprsInt = dyadicExpr' (A.Int,A.Int) "*"
|
|
|
|
-- | Divide two expressions.
|
|
divExprsInt :: DyadicExpr
|
|
divExprsInt = dyadicExpr' (A.Int,A.Int) "/"
|