cao-0.1: src/Language/CAO/Platform/Query.hs
{- |
Module : $Header$
Description : Queries about the target platform.
Copyright : (c) SMART Team / HASLab
License : GPL
Maintainer : Paulo Silva <paufil@di.uminho.pt>
Stability : experimental
Portability : non-portable
Query and utility functions about the target platform.
-}
module Language.CAO.Platform.Query where
import Control.Monad
import Data.Array
import Data.Maybe
import Language.CAO.Common.Error
import Language.CAO.Common.Literal
import Language.CAO.Common.Monad
import Language.CAO.Common.Polynomial
import Language.CAO.Common.SrcLoc
import Language.CAO.Common.Var
import Language.CAO.Index
import Language.CAO.Platform.Literals
import Language.CAO.Platform.Naming
import Language.CAO.Platform.Specification
import Language.CAO.Type
--------------------------------------------------------------------------------
-- These are the main query function which are used to encapsulate all searches.
queryTTS :: TypeTransSpec -> [TypeSpec]
queryTTS tts =
map snd (ubitsT tts) ++
map snd (sbitsT tts) ++
map snd (modT tts) ++
map snd (vectorT tts) ++
map snd (matrixT tts) ++
(catMaybes $
boolT tts :
intT tts :
rintT tts :
structT tts :
modpolT tts :
[])
{-
- Translations for matrices with just one dimension specified?
- Structs of differnt sizes
-}
query :: TranslationSpec -> Type Var -> Maybe TypeSpec
query tspec typ =
either id (uncurry sizedTypeQuery) (worker typ) $ typeTransSpec tspec
where
worker tp = case tp of
Int -> Left intT
RInt -> Left rintT
Bool -> Left boolT
Bits sg n -> let
f = case sg of
U -> ubitsT
S -> sbitsT
in Right (f, auxIndex n)
Mod Nothing Nothing (Pol [Mon (CoefI m) EZero]) ->
Right (modT, auxIndex m)
Mod _ _ _ -> Left modpolT
-- TODO: specific polynomial
Vector n _ -> Right (vectorT, auxIndex n)
Matrix n m _ -> Right (matrixT, combineM (auxIndex n) (auxIndex m))
Struct {} -> Left structT
SField _ t -> worker t
Index _ _ t -> worker t
_ -> error "query: Not expectd type"
auxIndex n =
case n of
IInt n' -> Simple n'
IInd v -> case indConst v of
Just (IInt n') -> Simple n'
_ -> Generic
_ -> Generic
combineM (Simple n) (Simple m) = MSize n m
combineM _ _ = Generic
sizedTypeQuery :: (TypeTransSpec -> [(Size, TypeSpec)]) -> Size -> TypeTransSpec -> Maybe TypeSpec
sizedTypeQuery typ size ttspec = let
t = typ ttspec
in maybe (lookup Generic t) Just $ lookup size t
--------------------------------------------------------------------------------
-- Checks the query result, and raises an exception if the type is not supported.
queryType
:: CaoMonad m
=> TranslationSpec -> Type Var
-> m TypeSpec
queryType tspec typ = maybe
(caoError defSrcLoc $ NotSupportedTypeErr typ)
return
$ query tspec typ
queryOperation
:: CaoMonad m
=> TranslationSpec -> Type Var -> OpCode
-> m (OpReturn, Consts, SafetyConv)
queryOperation tspec typ op = do
m <- queryType tspec typ
maybe (caoError defSrcLoc $ NotSupportedOp (operationNames ! op) typ)
return
$ operations m ! op
--------------------------------------------------------------------------------
varOrMacroDecl :: CaoMonad m => TranslationSpec -> Type Var -> m a -> m a -> m a
varOrMacroDecl tspec typ f1 f2 = queryType tspec typ >>= aux . declConv
where
aux VarDecl = f1
aux MacroDecl = f2
autoOrAlloc :: CaoMonad m => TranslationSpec -> Type Var -> m a -> m a -> m a
autoOrAlloc tspec typ f1 f2 = queryType tspec typ >>= aux . memoryConv
where
aux Auto = f1
aux AutoRef = f1
aux Alloc = f2
valOrRef :: CaoMonad m => TranslationSpec -> Type Var -> m a -> m a -> m a
valOrRef tspec typ f1 f2 = queryType tspec typ >>= aux . memoryConv
where
aux Auto = f1
aux AutoRef = f2
aux Alloc = f2
valOrRefFuncReturn :: CaoMonad m => TranslationSpec -> Type Var -> m a -> m a -> m a
valOrRefFuncReturn tspec typ f1 f2 = queryType tspec typ >>= aux . funcCall
where
aux FFuncReturn = f1
aux FFuncRef = f2
valOrRefOpReturn :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m a -> m a -> m a
valOrRefOpReturn tspec typ op f1 f2 = queryOperation tspec typ op >>= aux
where
aux (rc, _, _) = case rc of
OMacroReturn -> f1
OFuncReturn -> f1
OMacroRef -> f2
OFuncRef -> f2
opReturnKind' :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m a -> m a -> m a -> m a -> m a
opReturnKind' tspec typ op f1 f2 f3 f4 = queryOperation tspec typ op >>= aux
where
aux (rc, _, _) = case rc of
OFuncReturn -> f1
OFuncRef -> f2
OMacroReturn -> f3
OMacroRef -> f4
valOrRefOpMacroReturn :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m a -> m a -> m a
valOrRefOpMacroReturn tspec typ op f1 f2 = queryOperation tspec typ op >>= aux
where
aux (rc, _, _) = case rc of
OMacroReturn -> f1
OMacroRef -> f2
_ -> caoError defSrcLoc $ NotSupportedOp (operationNames ! op) typ
globalOrInlinedField :: CaoMonad m => TranslationSpec -> m a -> m a -> m a
globalOrInlinedField tspec f1 f2 = case structFields $ globalTransSpec tspec of
GlobalF -> f1
InlinedF -> f2
safeOfUnsafe :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m a -> m a -> m a -> m a
safeOfUnsafe tspec typ op f1 f2 f3 = queryOperation tspec typ op >>= aux
where
aux (_,_, saf) = case saf of
Safe -> f1
Unsafe -> f2
ArgSafe -> f3
safeOrUnsafeDefault :: CaoMonad m => TranslationSpec -> m a -> m a -> m a -> m a
safeOrUnsafeDefault tspec f1 f2 f3 =
case defaultSafety $ globalTransSpec tspec of
Safe -> f1
Unsafe -> f2
ArgSafe -> f3
checkLiteral :: CaoMonad m => TranslationSpec -> Type Var -> m a -> (LitCheck -> m a) -> m a
checkLiteral tspec typ f1 f2 = queryType tspec typ >>= maybe f1 f2 . literal
--------------------------------------------------------------------------------
-- Encapsulated queries
-- How to deal with literals
operandKind :: CaoMonad m => TranslationSpec -> Type Var -> OpCode -> m Consts
operandKind tspec typ op = queryOperation tspec typ op >>= aux
where
aux (_, rc, _) = return rc
operandKindGeneral :: CaoMonad m => TranslationSpec -> Type Var -> m Consts
operandKindGeneral tspec typ = liftM operands $ queryType tspec typ
codes :: CaoMonad m => TranslationSpec -> Type Var -> m String
codes tspec typ = liftM code $ queryType tspec typ
typeName :: CaoMonad m => TranslationSpec -> Type Var -> m String
typeName tspec typ = liftM nameInPlat $ queryType tspec typ
existsModWithBase :: TranslationSpec -> Integer -> Bool
existsModWithBase tspec n = maybe False (const True) $ lookup (Simple n) $ modT $ typeTransSpec tspec