diff --git a/fco2/AST.hs b/fco2/AST.hs index c4f797d..d6bc63d 100644 --- a/fco2/AST.hs +++ b/fco2/AST.hs @@ -109,6 +109,7 @@ data Expression = | True Meta | False Meta | FunctionCall Meta Name [Expression] + | IntrinsicFunctionCall Meta String [Expression] | SubscriptedExpr Meta Subscript Expression | BytesInExpr Meta Expression | BytesInType Meta Type diff --git a/fco2/GenerateC.hs b/fco2/GenerateC.hs index df1d96f..71aa269 100644 --- a/fco2/GenerateC.hs +++ b/fco2/GenerateC.hs @@ -394,6 +394,7 @@ genExpression (A.ExprLiteral m l) = genLiteral l genExpression (A.True m) = tell ["true"] genExpression (A.False m) = tell ["false"] --genExpression (A.FunctionCall m n es) +genExpression (A.IntrinsicFunctionCall m s es) = genIntrinsicFunction m s es --genExpression (A.SubscriptedExpr m s e) --genExpression (A.BytesInExpr m e) genExpression (A.BytesInType m t) = genBytesInType t @@ -405,6 +406,13 @@ genTypeSymbol s t = case scalarType t of Just ct -> tell ["occam_", s, "_", ct] Nothing -> missing $ "genTypeSymbol " ++ show t + +genIntrinsicFunction :: Meta -> String -> [A.Expression] -> CGen () +genIntrinsicFunction m s es + = do tell ["occam_", s, " ("] + sequence [genExpression e >> genComma | e <- es] + genMeta m + tell [")"] --}}} --{{{ operators diff --git a/fco2/Intrinsics.hs b/fco2/Intrinsics.hs new file mode 100644 index 0000000..ed9ab71 --- /dev/null +++ b/fco2/Intrinsics.hs @@ -0,0 +1,16 @@ +-- | Definitions of intrinsic FUNCTIONs and PROCs. +module Intrinsics where + +import qualified AST as A + +intrinsicFunctions :: [(String, ([A.Type], [(A.Type, String)]))] +intrinsicFunctions = + [ ("SQRT", ([A.Real32], [(A.Real32, "value")])) + , ("DSQRT", ([A.Real64], [(A.Real64, "value")])) + ] + +intrinsicProcs :: [(String, [(A.AbbrevMode, A.Type, String)])] +intrinsicProcs = + [ ("ASSERT", [(A.ValAbbrev, A.Bool, "value")]) + ] + diff --git a/fco2/LANGUAGE b/fco2/LANGUAGE index 72995c6..25c76e1 100644 --- a/fco2/LANGUAGE +++ b/fco2/LANGUAGE @@ -12,4 +12,6 @@ what gets inlined). Intrinsics: - ASSERT +- SQRT +- DSQRT diff --git a/fco2/Makefile b/fco2/Makefile index e76f119..d081708 100644 --- a/fco2/Makefile +++ b/fco2/Makefile @@ -9,6 +9,7 @@ sources = \ EvalLiterals.hs \ GenerateC.hs \ Indentation.hs \ + Intrinsics.hs \ Main.hs \ Metadata.hs \ Parse.hs \ diff --git a/fco2/Parse.hs b/fco2/Parse.hs index 7ee36f6..1b3f06f 100644 --- a/fco2/Parse.hs +++ b/fco2/Parse.hs @@ -18,6 +18,7 @@ import Errors import EvalConstants import EvalLiterals import Indentation +import Intrinsics import Metadata import ParseState import Pass @@ -746,41 +747,9 @@ character "character" --}}} --{{{ expressions -functionNameSingle :: OccParser A.Name -functionNameSingle - = do n <- functionName - rts <- returnTypesOfFunction n - case rts of - [_] -> return n - _ -> pzero - "function with single return value" - -functionNameMulti :: OccParser A.Name -functionNameMulti - = do n <- functionName - rts <- returnTypesOfFunction n - case rts of - [_] -> pzero - _ -> return n - "function with multiple return values" - -functionActuals :: A.Name -> OccParser [A.Expression] -functionActuals func - = do A.Function _ _ fs _ <- specTypeOfName func - let ats = [t | A.Formal _ t _ <- fs] - sLeftR - es <- intersperseP (map expressionOfType ats) sComma - sRightR - return es - expressionList :: [A.Type] -> OccParser A.ExpressionList expressionList types - = do m <- md - n <- try functionNameMulti - as <- functionActuals n - rts <- returnTypesOfFunction n - matchTypes types rts - return $ A.FunctionCallList m n as + = functionMulti types <|> do m <- md es <- intersperseP (map expressionOfType types) sComma return $ A.ExpressionList m es @@ -870,6 +839,73 @@ operandOfType wantT matchType wantT t return o --}}} +--{{{ functions +functionNameValued :: Bool -> OccParser A.Name +functionNameValued isMulti + = do n <- functionName + rts <- returnTypesOfFunction n + case (rts, isMulti) of + ([_], False) -> return n + ((_:_:_), True) -> return n + _ -> pzero + "function name" + +functionActuals :: [A.Formal] -> OccParser [A.Expression] +functionActuals fs + = do let actuals = [expressionOfType t "actual for " ++ show n + | A.Formal _ t n <- fs] + es <- intersperseP actuals sComma + return es + +functionSingle :: OccParser A.Expression +functionSingle + = do m <- md + n <- tryVX (functionNameValued False) sLeftR + A.Function _ _ fs _ <- specTypeOfName n + as <- functionActuals fs + sRightR + return $ A.FunctionCall m n as + "single-valued function call" + +functionMulti :: [A.Type] -> OccParser A.ExpressionList +functionMulti types + = do m <- md + n <- tryVX (functionNameValued True) sLeftR + A.Function _ _ fs _ <- specTypeOfName n + as <- functionActuals fs + sRightR + rts <- returnTypesOfFunction n + matchTypes types rts + return $ A.FunctionCallList m n as + "multi-valued function call" +--}}} +--{{{ intrinsic functions +intrinsicFunctionName :: Bool -> OccParser (String, [A.Type], [A.Formal]) +intrinsicFunctionName isMulti + = do n <- anyName A.FunctionName + let s = A.nameName n + case (lookup s intrinsicFunctions, isMulti) of + (Nothing, _) -> pzero + (Just ([_], _), True) -> pzero + (Just ((_:_:_), _), False) -> pzero + (Just (rts, tns), _) -> + return (s, rts, [A.Formal A.ValAbbrev t (A.Name emptyMeta A.VariableName n) + | (t, n) <- tns]) + "intrinsic function name" + +intrinsicFunctionSingle :: OccParser A.Expression +intrinsicFunctionSingle + = do m <- md + (s, _, fs) <- tryVX (intrinsicFunctionName False) sLeftR + as <- functionActuals fs + sRightR + return $ A.IntrinsicFunctionCall m s as + "single-valued intrinsic function call" + +-- No support for multi-valued intrinsic functions, because I don't think there +-- are likely to be any, and supporting them in the C backend is slightly +-- tricky. +--}}} monadicOperator :: OccParser A.MonadicOp monadicOperator @@ -965,7 +1001,8 @@ operandNotTable' <|> do { m <- md; l <- literal; return $ A.ExprLiteral m l } <|> do { sLeftR; e <- expression; sRightR; return e } -- XXX value process - <|> do { m <- md; n <- try functionNameSingle; as <- functionActuals n; return $ A.FunctionCall m n as } + <|> functionSingle + <|> intrinsicFunctionSingle <|> do m <- md sBYTESIN sLeftR @@ -1720,11 +1757,6 @@ actual (A.Formal am t n) an = A.nameName n --}}} --{{{ intrinsic PROC call -intrinsicProcs :: [(String, [(A.AbbrevMode, A.Type, String)])] -intrinsicProcs = - [ ("ASSERT", [(A.ValAbbrev, A.Bool, "value")]) - ] - intrinsicProcName :: OccParser (String, [A.Formal]) intrinsicProcName = do n <- anyName A.ProcName @@ -1737,11 +1769,11 @@ intrinsicProcName intrinsicProc :: OccParser A.Process intrinsicProc = do m <- md - (n, fs) <- tryVX intrinsicProcName sLeftR + (s, fs) <- tryVX intrinsicProcName sLeftR as <- actuals fs sRightR eol - return $ A.IntrinsicProcCall m n as + return $ A.IntrinsicProcCall m s as "intrinsic PROC instance" --}}} --{{{ preprocessor directives diff --git a/fco2/Types.hs b/fco2/Types.hs index 8b70bf7..d4ee818 100644 --- a/fco2/Types.hs +++ b/fco2/Types.hs @@ -11,6 +11,7 @@ import Data.Maybe import qualified AST as A import Errors import EvalLiterals +import Intrinsics import ParseState import Metadata @@ -143,6 +144,7 @@ typeOfExpression e A.True m -> return A.Bool A.False m -> return A.Bool A.FunctionCall m n es -> liftM head $ returnTypesOfFunction n + A.IntrinsicFunctionCall _ s _ -> liftM head $ returnTypesOfIntrinsic s A.SubscriptedExpr m s e -> typeOfExpression e >>= subscriptType s A.BytesInExpr m e -> return A.Int @@ -166,6 +168,12 @@ returnTypesOfFunction n checkJust "not defined as a function" $ lookup (A.nameName n) (psFunctionReturns ps) +returnTypesOfIntrinsic :: (PSM m, Die m) => String -> m [A.Type] +returnTypesOfIntrinsic s + = case lookup s intrinsicFunctions of + Just (rts, _) -> return rts + Nothing -> die $ "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 :: (PSM m, Die m) => A.Variable -> m (Either [A.Type] [(A.Name, [A.Type])]) diff --git a/fco2/fco_support.h b/fco2/fco_support.h index e994e08..70b10f4 100644 --- a/fco2/fco_support.h +++ b/fco2/fco_support.h @@ -1,4 +1,5 @@ // C99 support definitions for FCO. +// vim:set foldmethod=marker: #ifndef FCO_SUPPORT_H #define FCO_SUPPORT_H @@ -9,9 +10,11 @@ #include #include #include +#include #include +//{{{ mostneg/mostpos #define occam_mostneg_bool false #define occam_mostpos_bool true #define occam_mostneg_char CHAR_MIN @@ -28,7 +31,9 @@ #define occam_mostpos_float FLT_MAX #define occam_mostneg_double -DBL_MAX #define occam_mostpos_double DBL_MAX +//}}} +//{{{ compiler-specific attributes #ifdef __GNUC__ #define occam_struct_packed __attribute__ ((packed)) #define occam_unused __attribute__ ((unused)) @@ -37,7 +42,9 @@ #define occam_struct_packed #define occam_unused #endif +//}}} +//{{{ runtime check functions #define occam_stop(pos, format, args...) \ do { \ EXTERNAL_CALLN (fprintf, stderr, "Program stopped at %s: " format "\n", pos, ##args); \ @@ -59,7 +66,9 @@ static int occam_check_index (int i, int limit, const char *pos) { } return i; } +//}}} +//{{{ type-specific runtime checks #define MAKE_RANGE_CHECK(type, format) \ static type occam_range_check_##type (type, type, type, const char *) occam_unused; \ static type occam_range_check_##type (type lower, type upper, type n, const char *pos) { \ @@ -163,5 +172,20 @@ MAKE_DIV(double) #undef MAKE_MUL #undef MAKE_DIV #undef MAKE_REM +//}}} + +//{{{ intrinsics +// FIXME These should do range checks. + +static float occam_SQRT (float, const char *) occam_unused; +static float occam_SQRT (float v, const char *pos) { + return sqrtf (v); +} + +static double occam_DSQRT (double, const char *) occam_unused; +static double occam_DSQRT (double v, const char *pos) { + return sqrt (v); +} +//}}} #endif diff --git a/fco2/testcases/intrinsics.occ b/fco2/testcases/intrinsics.occ index da8e649..f43d07c 100644 --- a/fco2/testcases/intrinsics.occ +++ b/fco2/testcases/intrinsics.occ @@ -1,4 +1,6 @@ PROC P () + REAL32 r: + REAL64 d: SEQ ASSERT (TRUE) -- check we can override an intrinsic @@ -6,4 +8,8 @@ PROC P () SKIP : ASSERT (FALSE) + + r := SQRT (3.141) + r := 41.5 + SQRT (SQRT (SQRT (4.0))) + d := DSQRT (3.141 (REAL64)) :