From 432c89e625d9c393d231a1e77179f1053b2c8eb6 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Sat, 21 Apr 2007 03:15:38 +0000 Subject: [PATCH] Make STOPs report where and why they stopped --- fco2/GenerateC.hs | 100 +++++++++++++++++++++++++-------------------- fco2/Makefile | 2 +- fco2/TODO | 7 ++-- fco2/fco_support.h | 22 ++++++---- 4 files changed, 75 insertions(+), 56 deletions(-) diff --git a/fco2/GenerateC.hs b/fco2/GenerateC.hs index 4b1eca8..990ebbc 100644 --- a/fco2/GenerateC.hs +++ b/fco2/GenerateC.hs @@ -104,6 +104,11 @@ inputType c im _ -> ITOther --}}} +--{{{ metadata +genMeta :: Meta -> CGen () +genMeta m = tell ["\"", show m, "\""] +--}}} + --{{{ names genName :: A.Name -> CGen () genName n = tell [[if c == '.' then '_' else c | c <- A.nameName n]] @@ -332,8 +337,8 @@ genArraySubscript v es --{{{ expressions genExpression :: A.Expression -> CGen () -genExpression (A.Monadic m op e) = genMonadic op e -genExpression (A.Dyadic m op e f) = genDyadic op e f +genExpression (A.Monadic m op e) = genMonadic m op e +genExpression (A.Dyadic m op e f) = genDyadic m op e f genExpression (A.MostPos m t) = genTypeConstant "mostpos" t genExpression (A.MostNeg m t) = genTypeConstant "mostneg" t --genExpression (A.SizeType m t) @@ -369,10 +374,10 @@ genSimpleMonadic s e genExpression e tell [")"] -genMonadic :: A.MonadicOp -> A.Expression -> CGen () -genMonadic A.MonadicSubtr e = genSimpleMonadic "-" e -genMonadic A.MonadicBitNot e = genSimpleMonadic "~" e -genMonadic A.MonadicNot e = genSimpleMonadic "!" e +genMonadic :: Meta -> A.MonadicOp -> A.Expression -> CGen () +genMonadic _ A.MonadicSubtr e = genSimpleMonadic "-" e +genMonadic _ A.MonadicBitNot e = genSimpleMonadic "~" e +genMonadic _ A.MonadicNot e = genSimpleMonadic "!" e genSimpleDyadic :: String -> A.Expression -> A.Expression -> CGen () genSimpleDyadic s e f @@ -382,35 +387,37 @@ genSimpleDyadic s e f genExpression f tell [")"] -genFuncDyadic :: String -> A.Expression -> A.Expression -> CGen () -genFuncDyadic s e f +genFuncDyadic :: Meta -> String -> A.Expression -> A.Expression -> CGen () +genFuncDyadic m s e f = do tell [s, " ("] genExpression e tell [", "] genExpression f + tell [", "] + genMeta m tell [")"] -genDyadic :: A.DyadicOp -> A.Expression -> A.Expression -> CGen () -genDyadic A.Add e f = genFuncDyadic "occam_add" e f -genDyadic A.Subtr e f = genFuncDyadic "occam_subtr" e f -genDyadic A.Mul e f = genFuncDyadic "occam_mul" e f -genDyadic A.Div e f = genFuncDyadic "occam_div" e f -genDyadic A.Rem e f = genFuncDyadic "occam_rem" e f -genDyadic A.Plus e f = genSimpleDyadic "+" e f -genDyadic A.Minus e f = genSimpleDyadic "-" e f -genDyadic A.Times e f = genSimpleDyadic "*" e f -genDyadic A.BitAnd e f = genSimpleDyadic "&" e f -genDyadic A.BitOr e f = genSimpleDyadic "|" e f -genDyadic A.BitXor e f = genSimpleDyadic "^" e f -genDyadic A.And e f = genSimpleDyadic "&&" e f -genDyadic A.Or e f = genSimpleDyadic "||" e f -genDyadic A.Eq e f = genSimpleDyadic "==" e f -genDyadic A.NotEq e f = genSimpleDyadic "!=" e f -genDyadic A.Less e f = genSimpleDyadic "<" e f -genDyadic A.More e f = genSimpleDyadic ">" e f -genDyadic A.LessEq e f = genSimpleDyadic "<=" e f -genDyadic A.MoreEq e f = genSimpleDyadic ">=" e f -genDyadic A.After e f = genFuncDyadic "occam_after" e f +genDyadic :: Meta -> A.DyadicOp -> A.Expression -> A.Expression -> CGen () +genDyadic m A.Add e f = genFuncDyadic m "occam_add" e f +genDyadic m A.Subtr e f = genFuncDyadic m "occam_subtr" e f +genDyadic m A.Mul e f = genFuncDyadic m "occam_mul" e f +genDyadic m A.Div e f = genFuncDyadic m "occam_div" e f +genDyadic m A.Rem e f = genFuncDyadic m "occam_rem" e f +genDyadic _ A.Plus e f = genSimpleDyadic "+" e f +genDyadic _ A.Minus e f = genSimpleDyadic "-" e f +genDyadic _ A.Times e f = genSimpleDyadic "*" e f +genDyadic _ A.BitAnd e f = genSimpleDyadic "&" e f +genDyadic _ A.BitOr e f = genSimpleDyadic "|" e f +genDyadic _ A.BitXor e f = genSimpleDyadic "^" e f +genDyadic _ A.And e f = genSimpleDyadic "&&" e f +genDyadic _ A.Or e f = genSimpleDyadic "||" e f +genDyadic _ A.Eq e f = genSimpleDyadic "==" e f +genDyadic _ A.NotEq e f = genSimpleDyadic "!=" e f +genDyadic _ A.Less e f = genSimpleDyadic "<" e f +genDyadic _ A.More e f = genSimpleDyadic ">" e f +genDyadic _ A.LessEq e f = genSimpleDyadic "<=" e f +genDyadic _ A.MoreEq e f = genSimpleDyadic ">=" e f +genDyadic m A.After e f = genFuncDyadic m "occam_after" e f --}}} --{{{ input/output items @@ -849,12 +856,12 @@ genProcess p = case p of A.Output m c ois -> genOutput c ois A.OutputCase m c t ois -> genOutputCase c t ois A.Skip m -> tell ["/* skip */\n"] - A.Stop m -> genStop + A.Stop m -> genStop m "STOP process" A.Main m -> tell ["/* main */\n"] A.Seq m ps -> sequence_ $ map genProcess ps A.SeqRep m r p -> genReplicator r (genProcess p) - A.If m s -> genIf s - A.Case m e s -> genCase e s + A.If m s -> genIf m s + A.Case m e s -> genCase m e s A.While m e p -> genWhile e p A.Par m pm ps -> genPar pm ps A.ParRep m pm r p -> genParRep pm r p @@ -895,11 +902,11 @@ genInput c im A.InputAfter m e -> genTimerWait e _ -> case im of A.InputSimple m is -> sequence_ $ map (genInputItem c) is - A.InputCase m s -> genInputCase c s + A.InputCase m s -> genInputCase m c s _ -> missing $ "genInput " ++ show im -genInputCase :: A.Variable -> A.Structured -> CGen () -genInputCase c s +genInputCase :: Meta -> A.Variable -> A.Structured -> CGen () +genInputCase m c s = do ps <- get t <- checkJust $ typeOfVariable ps c let proto = case t of A.Chan (A.UserProtocol n) -> n @@ -912,7 +919,7 @@ genInputCase c s tell ["switch (", tag, ") {\n"] genInputCaseBody proto c (return ()) s tell ["default:\n"] - genStop + genStop m "unhandled variant in CASE input" tell ["}\n"] -- This handles specs in a slightly odd way, because we can't insert specs into @@ -969,15 +976,18 @@ genOutputCase c tag ois genOutput c ois --}}} --{{{ stop -genStop :: CGen () -genStop = tell ["SetErr ();\n"] +genStop :: Meta -> String -> CGen () +genStop m s + = do tell ["occam_stop ("] + genMeta m + tell [", \"", s, "\");\n"] --}}} --{{{ if -genIf :: A.Structured -> CGen () -genIf s +genIf :: Meta -> A.Structured -> CGen () +genIf m s = do label <- makeNonce "if_end" genIfBody label s - genStop + genStop m "no choice matched in IF process" tell [label, ":\n;\n"] genIfBody :: String -> A.Structured -> CGen () @@ -992,13 +1002,15 @@ genIfBody label s = genStructured s doC tell ["}\n"] --}}} --{{{ case -genCase :: A.Expression -> A.Structured -> CGen () -genCase e s +genCase :: Meta -> A.Expression -> A.Structured -> CGen () +genCase m e s = do tell ["switch ("] genExpression e tell [") {\n"] seenDefault <- genCaseBody (return ()) s - when (not seenDefault) $ tell ["default:\n"] >> genStop + when (not seenDefault) $ + do tell ["default:\n"] + genStop m "no option matched in CASE process" tell ["}\n"] -- FIXME -- can this be made common with genInputCaseBody above? diff --git a/fco2/Makefile b/fco2/Makefile index d7c69cc..d52e6a8 100644 --- a/fco2/Makefile +++ b/fco2/Makefile @@ -28,7 +28,7 @@ CFLAGS = -g -std=gnu99 -Wall `kroc --cflags` `kroc --ccincpath` ./fco -v $< >$@ || ( rm -f $@; exit 1 ) indent -kr -pcs $@ -%.fco: %.fco.o kroc-wrapper-c.o kroc-wrapper.occ +%.fco: %.fco.o fco_support.h kroc-wrapper-c.o kroc-wrapper.occ kroc -o $@ kroc-wrapper.occ $< kroc-wrapper-c.o -lcif tests = $(wildcard testcases/*.occ) diff --git a/fco2/TODO b/fco2/TODO index 8cc6259..604a3d9 100644 --- a/fco2/TODO +++ b/fco2/TODO @@ -22,6 +22,7 @@ Types needs cleaning up and Haddocking. Types should provide versions of the functions that work in a state monad. If we can make them work in the parser monad (by providing an instance of MonadState for it?), that'd be even better. + See: http://hackage.haskell.org/trac/ghc/ticket/1274 Errors is nearly useless, because none of our monads really fail in sensible ways. @@ -66,9 +67,6 @@ lot of the "_sizes unused" warnings). We could have genSpec generate {} around specs if it's not immediately inside another spec (which'd require some extra boolean arguments to find out). -There should be a wrapper for SetErr that takes a Meta and an error message. -Ops and array references should use it. - Replicator loops should be special-cased for when base == 0 to generate the sort of loop a C programmer would normally write. @@ -89,6 +87,9 @@ to be a bad idea for very large counts (since I assume it'll allocate off the stack). We should probably do a malloc if it's not determinable at compile time. +The operator functions need to have the type name attached -- they'll only work +for INT at the moment. + ## Long-term If we have constant folding, we're three-quarters of the way towards having an diff --git a/fco2/fco_support.h b/fco2/fco_support.h index cbf69e6..85ce3d9 100644 --- a/fco2/fco_support.h +++ b/fco2/fco_support.h @@ -8,6 +8,7 @@ #include #include #include +#include #include @@ -34,29 +35,34 @@ #warning No PACKED implementation for this compiler #endif +static void occam_stop (const char *pos, const char *message) { + EXTERNAL_CALLN (fprintf, stderr, "Program stopped at %s: %s\n", pos, message); + SetErr (); +} + /* FIXME All of these need to check for overflow and report errors appropriately. */ -static int occam_add (int a, int b) { +static int occam_add (int a, int b, const char *pos) { return a + b; } -static int occam_subtr (int a, int b) { +static int occam_subtr (int a, int b, const char *pos) { return a - b; } -static int occam_mul (int a, int b) { +static int occam_mul (int a, int b, const char *pos) { return a * b; } -static int occam_div (int a, int b) { +static int occam_div (int a, int b, const char *pos) { if (b == 0) { - SetErr (); + occam_stop (pos, "divide by zero"); } return a / b; } -static int occam_rem (int a, int b) { +static int occam_rem (int a, int b, const char *pos) { if (b == 0) { - SetErr (); + occam_stop (pos, "modulo by zero"); } return a % b; } -#define occam_after (a, b) \ +#define occam_after (a, b, pos) \ (((a) - (b)) > 0) #endif