From 2f7539bcdb328b7932e0405bd8fe3746dd167e30 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Fri, 7 Mar 2008 17:50:10 +0000 Subject: [PATCH] Convert the C backend to the new CIF API (mostly). Most of this is mechanical: changing function names, and carrying the "wptr" argument around. I've made the code for computing Expressions from Structureds a bit more generic too. The only complex bit is the handling of PAR processes, which I'm not very happy with at the moment; they used to use the normal C calling convention, but now you need to pack the arguments into the workspace. I'm handling this at the moment by generating wrapper functions that do the unpacking, but it would be better in the future to make the wrapper PROCs that we already generate have the right interface. This won't work for programs that use any of the top-level channels yet, since there are no handlers for them. --- backends/GenerateC.hs | 253 ++++++++++++++++++++----------------- backends/GenerateCBased.hs | 2 +- backends/GenerateCPPCSP.hs | 4 +- backends/GenerateCTest.hs | 82 ++++++------ common/Types.hs | 28 ++-- 5 files changed, 197 insertions(+), 172 deletions(-) diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index 6d6d0f7..f989b04 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -160,16 +160,20 @@ cgenTopLevel s cs <- get (tlpName, chans) <- tlpInterface - tell ["extern int " ++ nameString n ++ "_stack_size;\n" - | n <- tlpName : (Set.toList $ csParProcs cs)] + sequence_ $ map (call genForwardDeclaration) + (listify (const True :: A.Specification -> Bool) s) + + tell ["/* ", show $ csParProcs cs, " */\n"] + sequence_ [do tell ["extern int " ++ nameString n ++ "_wrapper_stack_size;\n"] + cgenProcWrapper n + | n <- tlpName : (Set.toList $ csParProcs cs)] - sequence_ $ map (call genForwardDeclaration) (listify (const True :: A.Specification -> Bool) s) call genStructured s (\m _ -> tell ["\n#error Invalid top-level item: ", show m]) tell ["void tock_main (Workspace wptr) {\n\ \ Workspace tlp = ProcAlloc (wptr, ", show $ length chans, ", "] genName tlpName - tell ["_stack_size);\n"] + tell ["_wrapper_stack_size);\n"] sequence_ [do tell [" ProcParam (wptr, tlp, " ++ show i ++ ", "] call genTLPChannel c tell [");\n"] @@ -180,7 +184,7 @@ cgenTopLevel s \ LightProcBarrierInit (wptr, &bar, 1);\n\ \ LightProcStart (wptr, &bar, tlp, (Process) "] genName tlpName - tell [");\n\ + tell ["_wrapper);\n\ \ LightProcBarrierWait (wptr, &bar);\n\ \ Shutdown (wptr);\n\ \}\n\ @@ -280,7 +284,7 @@ cgetScalarType A.Int32 = Just "int32_t" cgetScalarType A.Int64 = Just "int64_t" cgetScalarType A.Real32 = Just "float" cgetScalarType A.Real64 = Just "double" -cgetScalarType A.Timer = Just "Time" +cgetScalarType A.Timer = Just "Time" -- Not used in the C backend. cgetScalarType A.Time = Just "Time" cgetScalarType _ = Nothing @@ -888,7 +892,7 @@ cgenInputItem :: A.Variable -> A.InputItem -> CGen () cgenInputItem c (A.InCounted m cv av) = do call genInputItem c (A.InVariable m cv) t <- typeOfVariable av - tell ["ChanIn("] + tell ["ChanIn(wptr,"] call genVariable c tell [","] fst $ abbrevVariable A.Abbrev t av @@ -903,13 +907,13 @@ cgenInputItem c (A.InVariable m v) let rhs = fst $ abbrevVariable A.Abbrev t v case t of A.Int -> - do tell ["ChanInInt("] + do tell ["ChanInInt(wptr,"] call genVariable c tell [","] rhs tell [");"] _ -> - do tell ["ChanIn("] + do tell ["ChanIn(wptr,"] call genVariable c tell [","] rhs @@ -923,7 +927,7 @@ cgenOutputItem c (A.OutCounted m ce ae) t <- typeOfExpression ae case ae of A.ExprVariable m v -> - do tell ["ChanOut("] + do tell ["ChanOut(wptr,"] call genVariable c tell [","] fst $ abbrevVariable A.Abbrev t v @@ -937,13 +941,13 @@ cgenOutputItem c (A.OutExpression m e) = do t <- typeOfExpression e case (t, e) of (A.Int, _) -> - do tell ["ChanOutInt("] + do tell ["ChanOutInt(wptr,"] call genVariable c tell [","] call genExpression e tell [");"] (_, A.ExprVariable _ v) -> - do tell ["ChanOut("] + do tell ["ChanOut(wptr,"] call genVariable c tell [","] fst $ abbrevVariable A.Abbrev t v @@ -1166,6 +1170,7 @@ cgenDeclaration (A.Array ds t) n True tell ["int "] genName n tell ["_sizes[",show $ length ds,"];"] +cgenDeclaration A.Timer _ _ = return () cgenDeclaration t n _ = do call genType t tell [" "] @@ -1201,7 +1206,7 @@ cgenArraySizesLiteral n (A.Array ds _) -- | Initialise an item being declared. cdeclareInit :: Meta -> A.Type -> A.Variable -> Maybe A.Expression -> Maybe (CGen ()) cdeclareInit _ (A.Chan A.DirUnknown _ _) var _ - = Just $ do tell ["ChanInit("] + = Just $ do tell ["ChanInit(wptr,"] call genVariableUnchecked var tell [");"] cdeclareInit m t@(A.Array ds t') var _ @@ -1327,7 +1332,7 @@ cintroduceSpec (A.Specification _ n (A.Proc _ sm fs p)) = do call genSpecMode sm tell ["void "] genName n - tell [" (Process *me"] + tell [" (Workspace wptr"] call genFormals fs tell [") {\n"] call genProcess p @@ -1365,13 +1370,12 @@ cgenRecordTypeSpec n b fs genName n tell [";"] - cgenForwardDeclaration :: A.Specification -> CGen () cgenForwardDeclaration (A.Specification _ n (A.Proc _ sm fs _)) = do call genSpecMode sm tell ["void "] genName n - tell [" (Process *me"] + tell [" (Workspace wptr"] call genFormals fs tell [");"] cgenForwardDeclaration (A.Specification _ n (A.RecordType _ b fs)) @@ -1401,43 +1405,88 @@ cgenActuals :: [A.Actual] -> CGen () cgenActuals as = prefixComma (map (call genActual) as) cgenActual :: A.Actual -> CGen () -cgenActual actual - = case actual of - A.ActualExpression t e -> - case (t, e) of - (A.Array _ _, A.ExprVariable _ v) -> - do call genVariable v - tell [","] - call genVariable v - tell ["_sizes"] - _ -> call genExpression e - A.ActualVariable am t v -> - case t of - A.Array _ _ -> - do call genVariable v - tell [","] - call genVariable v - tell ["_sizes"] - _ -> fst $ abbrevVariable am t v - -numCArgs :: [A.Actual] -> Int -numCArgs [] = 0 -numCArgs (A.ActualVariable _ (A.Array _ _) _:fs) = 2 + numCArgs fs -numCArgs (A.ActualExpression (A.Array _ _) _:fs) = 2 + numCArgs fs -numCArgs (_:fs) = 1 + numCArgs fs +cgenActual actual = seqComma $ realActuals actual cgenFormals :: [A.Formal] -> CGen () cgenFormals fs = prefixComma (map (call genFormal) fs) cgenFormal :: A.Formal -> CGen () -cgenFormal (A.Formal am t n) +cgenFormal f = seqComma [t >> tell [" "] >> n | (t, n) <- realFormals f] + +-- | Return generators for all the real actuals corresponding to a single +-- actual. +realActuals :: A.Actual -> [CGen ()] +realActuals (A.ActualExpression t e) + = case (t, e) of + (A.Array _ _, A.ExprVariable _ v) -> + [call genVariable v, + call genVariable v >> tell ["_sizes"]] + _ -> [call genExpression e] +realActuals (A.ActualVariable am t v) + = case t of + A.Array _ _ -> + [call genVariable v, + call genVariable v >> tell ["_sizes"]] + _ -> [fst $ abbrevVariable am t v] + +-- | Return (type, name) generator pairs for all the real formals corresponding +-- to a single formal. +realFormals :: A.Formal -> [(CGen (), CGen ())] +realFormals (A.Formal am t n) = case t of A.Array _ t' -> - do call genDecl am t n - tell [", const int *"] - genName n - tell ["_sizes"] - _ -> call genDecl am t n + [(mainType, mainName), + (tell ["const int *"], genName n >> tell ["_sizes"])] + _ -> [(mainType, mainName)] + where + mainType = cgenDeclType am t + mainName = genName n + +-- | Generate a wrapper function for a PAR subprocess. +cgenProcWrapper :: A.Name -> CGen () +cgenProcWrapper n + = do st <- specTypeOfName n + let fs = case st of A.Proc _ _ fs _ -> fs + let rfs = concatMap realFormals fs + + tell ["static void "] + genName n + tell ["_wrapper (Workspace wptr) {\n"] + + sequence_ [unpackParam num rf | (num, rf) <- zip [0..] rfs] + genName n + tell [" (wptr"] + prefixComma [n | (_, n) <- rfs] + tell [");\n"] + + tell ["}\n"] + where + unpackParam :: Int -> (CGen (), CGen ()) -> CGen () + unpackParam num (t, n) + = do t + tell [" "] + n + tell [" = ProcGetParam (wptr, " ++ show num ++ ", "] + t + tell [");\n"] + +-- | Generate a ProcAlloc for a PAR subprocess, returning a nonce for the +-- workspace pointer and the name of the function to call. +cgenProcAlloc :: A.Name -> [A.Actual] -> CGen (String, CGen ()) +cgenProcAlloc n as + = do let ras = concatMap realActuals as + + ws <- makeNonce "workspace" + tell ["Workspace ", ws, " = ProcAlloc (wptr, ", show $ length ras, ", "] + genName n + tell ["_wrapper_stack_size);\n"] + + sequence_ [do tell ["ProcParam (wptr, ", ws, ", ", show num, ", "] + ra + tell [");\n"] + | (num, ra) <- zip [(0 :: Int)..] ras] + + return (ws, genName n >> tell ["_wrapper"]) --}}} --{{{ processes @@ -1447,7 +1496,7 @@ cgenProcess p = case p of A.Input m c im -> call genInput c im A.Output m c ois -> call genOutput c ois A.OutputCase m c t ois -> call genOutputCase c t ois - A.GetTime m v -> call genGetTime m v + A.GetTime m v -> call genGetTime v A.Wait m wm e -> call genWait wm e A.Skip m -> tell ["/* skip */\n"] A.Stop m -> call genStop m "STOP process" @@ -1494,31 +1543,23 @@ cgenInput c im _ -> call genMissing $ "genInput " ++ show im cgenTimerRead :: A.Variable -> A.Variable -> CGen () -cgenTimerRead c v - = do tell ["ProcTime (&"] - call genVariable c - tell [");\n"] - call genVariable v - tell [" = "] - call genVariable c - tell [";\n"] +cgenTimerRead _ v = cgenGetTime v cgenTimerWait :: A.Expression -> CGen () cgenTimerWait e - = do tell ["ProcTimeAfter("] + = do tell ["TimerWait(wptr,"] call genExpression e tell [");"] -cgenGetTime :: Meta -> A.Variable -> CGen () -cgenGetTime m v - = do tell ["ProcTime(&"] - call genVariable v - tell [");"] +cgenGetTime :: A.Variable -> CGen () +cgenGetTime v + = do call genVariable v + tell [" = TimerRead(wptr);"] cgenWait :: A.WaitMode -> A.Expression -> CGen () cgenWait A.WaitUntil e = call genTimerWait e cgenWait A.WaitFor e - = do tell ["ProcAfter("] + = do tell ["TimerDelay(wptr,"] call genExpression e tell [");"] @@ -1531,7 +1572,7 @@ cgenOutputCase :: A.Variable -> A.Name -> [A.OutputItem] -> CGen () cgenOutputCase c tag ois = do t <- typeOfVariable c let proto = case t of A.Chan _ _ (A.UserProtocol n) -> n - tell ["ChanOutInt("] + tell ["ChanOutInt(wptr,"] call genVariable c tell [","] genName tag @@ -1545,7 +1586,7 @@ cgenStop :: Meta -> String -> CGen () cgenStop m s = do tell ["occam_stop("] genMeta m - tell [",\"", s, "\");"] + tell [",1,\"", s, "\");"] --}}} --{{{ seq cgenSeq :: A.Structured A.Process -> CGen () @@ -1616,66 +1657,46 @@ cgenWhile e p tell ["}"] --}}} --{{{ par +-- FIXME: The ParMode is now ignored (as it is in occ21), so PRI PAR behaves +-- the same as PAR. cgenPar :: A.ParMode -> A.Structured A.Process -> CGen () cgenPar pm s - = do (size, _, _) <- constantFold $ addOne (sizeOfStructured s) - pids <- makeNonce "pids" - pris <- makeNonce "priorities" - index <- makeNonce "i" - when (pm == A.PriPar) $ - do tell ["int ", pris, "["] - call genExpression size - tell ["];\n"] - tell ["Process *", pids, "["] - call genExpression size - tell ["];\n"] - tell ["int ", index, " = 0;\n"] - call genStructured s (createP pids pris index) - tell [pids, "[", index, "] = NULL;\n"] - tell ["if(",pids,"[0] != NULL){"] -- CIF seems to deadlock when you give ProcParList a list - -- beginning with NULL (i.e. with no processes) - case pm of - A.PriPar -> tell ["ProcPriParList (", pids, ", ", pris, ");\n"] - _ -> tell ["ProcParList (", pids, ");\n"] - tell ["}"] - tell [index, " = 0;\n"] - call genStructured s (freeP pids index) - where - createP pids pris index _ p - = do when (pm == A.PriPar) $ - tell [pris, "[", index, "] = ", index, ";\n"] - tell [pids, "[", index, "++] = "] - genProcAlloc p - tell [";\n"] - freeP pids index _ _ - = do tell ["ProcAllocClean (", pids, "[", index, "++]);\n"] + = do (count, _, _) <- constantFold $ countStructured s - genProcAlloc :: A.Process -> CGen () - genProcAlloc (A.ProcCall m n as) - = do tell ["ProcAlloc ("] - genName n - let stackSize = nameString n ++ "_stack_size" - tell [", ", stackSize, ", ", show $ numCArgs as] - call genActuals as - tell [")"] - genProcAlloc p = call genMissing $ "genProcAlloc " ++ show p + bar <- makeNonce "par_barrier" + tell ["LightProcBarrier ", bar, ";\n"] + tell ["LightProcBarrierInit (wptr, &", bar, ", "] + call genExpression count + tell [");\n"] + + call genStructured s (startP bar) + + tell ["LightProcBarrierWait (wptr, &", bar, ");\n"] + + where + startP :: String -> Meta -> A.Process -> CGen () + startP bar _ (A.ProcCall _ n as) + = do (ws, func) <- cgenProcAlloc n as + tell ["LightProcStart (wptr, &", bar, ", ", ws, ", "] + func + tell [");\n"] --}}} --{{{ alt cgenAlt :: Bool -> A.Structured A.Alternative -> CGen () cgenAlt isPri s - = do tell ["AltStart ();\n"] + = do tell ["Alt (wptr);\n"] tell ["{\n"] genAltEnable s tell ["}\n"] -- Like occ21, this is always a PRI ALT, so we can use it for both. - tell ["AltWait ();\n"] + tell ["AltWait (wptr);\n"] id <- makeNonce "alt_id" tell ["int ", id, " = 0;\n"] tell ["{\n"] genAltDisable id s tell ["}\n"] fired <- makeNonce "alt_fired" - tell ["int ", fired, " = AltEnd ();\n"] + tell ["int ", fired, " = AltEnd (wptr);\n"] tell [id, " = 0;\n"] label <- makeNonce "alt_end" tell ["{\n"] @@ -1690,10 +1711,10 @@ cgenAlt isPri s = case alt of A.Alternative _ c im _ -> doIn c im A.AlternativeCond _ e c im _ -> withIf e $ doIn c im - A.AlternativeSkip _ e _ -> withIf e $ tell ["AltEnableSkip ();\n"] + A.AlternativeSkip _ e _ -> withIf e $ tell ["AltEnableSkip (wptr);\n"] --transformWaitFor should have removed all A.WaitFor guards (transforming them into A.WaitUntil): A.AlternativeWait _ A.WaitUntil e _ -> - do tell ["AltEnableTimer ( "] + do tell ["AltEnableTimer (wptr,"] call genExpression e tell [" );\n"] @@ -1701,11 +1722,11 @@ cgenAlt isPri s = do case im of A.InputTimerRead _ _ -> call genMissing "timer read in ALT" A.InputTimerAfter _ time -> - do tell ["AltEnableTimer ("] + do tell ["AltEnableTimer (wptr,"] call genExpression time tell [");\n"] _ -> - do tell ["AltEnableChannel ("] + do tell ["AltEnableChannel (wptr,"] call genVariable c tell [");\n"] @@ -1716,20 +1737,20 @@ cgenAlt isPri s = case alt of A.Alternative _ c im _ -> doIn c im A.AlternativeCond _ e c im _ -> withIf e $ doIn c im - A.AlternativeSkip _ e _ -> withIf e $ tell ["AltDisableSkip (", id, "++);\n"] + A.AlternativeSkip _ e _ -> withIf e $ tell ["AltDisableSkip (wptr,", id, "++);\n"] A.AlternativeWait _ A.WaitUntil e _ -> - do tell ["AltDisableTimer (", id, "++, "] + do tell ["AltDisableTimer (wptr,", id, "++, "] call genExpression e tell [");\n"] doIn c im = do case im of A.InputTimerRead _ _ -> call genMissing "timer read in ALT" A.InputTimerAfter _ time -> - do tell ["AltDisableTimer (", id, "++, "] + do tell ["AltDisableTimer (wptr,", id, "++, "] call genExpression time tell [");\n"] _ -> - do tell ["AltDisableChannel (", id, "++, "] + do tell ["AltDisableChannel (wptr,", id, "++, "] call genVariable c tell [");\n"] @@ -1767,7 +1788,7 @@ withIf cond body cgenProcCall :: A.Name -> [A.Actual] -> CGen () cgenProcCall n as = do genName n - tell [" (me"] + tell [" (wptr"] call genActuals as tell [");\n"] --}}} diff --git a/backends/GenerateCBased.hs b/backends/GenerateCBased.hs index 53f6fa3..1408cda 100644 --- a/backends/GenerateCBased.hs +++ b/backends/GenerateCBased.hs @@ -122,7 +122,7 @@ data GenOps = GenOps { genFuncDyadic :: Meta -> String -> A.Expression -> A.Expression -> CGen (), genFuncMonadic :: Meta -> String -> A.Expression -> CGen (), -- | Gets the current time into the given variable - genGetTime :: Meta -> A.Variable -> CGen (), + genGetTime :: A.Variable -> CGen (), -- | Generates an IF statement (which can have replicators, specifications and such things inside it). genIf :: Meta -> A.Structured A.Choice -> CGen (), genInput :: A.Variable -> A.InputMode -> CGen (), diff --git a/backends/GenerateCPPCSP.hs b/backends/GenerateCPPCSP.hs index 74faa89..59dc6d4 100644 --- a/backends/GenerateCPPCSP.hs +++ b/backends/GenerateCPPCSP.hs @@ -248,8 +248,8 @@ cppgenTimerRead c v call genVariable c tell ["),4294967296.0);\n"] -cppgenGetTime :: Meta -> A.Variable -> CGen () -cppgenGetTime m v +cppgenGetTime :: A.Variable -> CGen () +cppgenGetTime v = do tell ["csp::CurrentTime(&"] call genVariable v tell [");"] diff --git a/backends/GenerateCTest.hs b/backends/GenerateCTest.hs index f789b8a..4391769 100644 --- a/backends/GenerateCTest.hs +++ b/backends/GenerateCTest.hs @@ -285,7 +285,7 @@ testGenType = TestList testStop :: Test testStop = - testBoth "Stop" "occam_stop(\"foo:4:9\",\"bar\");" "throw StopException(\"foo:4:9\" \"bar\");" (tcall2 genStop (Meta (Just "foo") 4 9) "bar") + testBoth "Stop" "occam_stop(\"foo:4:9\",1,\"bar\");" "throw StopException(\"foo:4:9\" \"bar\");" (tcall2 genStop (Meta (Just "foo") 4 9) "bar") testArraySizes :: Test testArraySizes = TestList @@ -487,16 +487,16 @@ testDeclareInitFree = TestLabel "testDeclareInitFree" $ TestList ,testAllSameInit 10 ("foo=3;","") A.Int (intLiteral 3) -- Channel types: - ,testAll 1 ("ChanInit((&foo));","") ("","") $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int + ,testAll 1 ("ChanInit(wptr,(&foo));","") ("","") $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int ,testAllSame 2 ("","") $ A.Chan A.DirInput (A.ChanAttributes False False) A.Int -- Plain arrays: ,testAllSame 3 ("","") $ A.Array [A.Dimension 4] A.Int -- Channel arrays: - ,testAll 4 ("tock_init_chan_array(foo_storage,foo,4);^ChanInit(foo[0]);^","") ("tockInitChanArray(foo_storage,foo_actual,4);","") $ A.Array [A.Dimension 4] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int + ,testAll 4 ("tock_init_chan_array(foo_storage,foo,4);^ChanInit(wptr,foo[0]);^","") ("tockInitChanArray(foo_storage,foo_actual,4);","") $ A.Array [A.Dimension 4] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int -- The subscripting on this test is incomplete; it should probably be fixed at some point: - ,testAll 5 ("tock_init_chan_array(foo_storage,foo,4*5*6);^ChanInit(foo[0*foo_sizes[1]*foo_sizes[2]]);^","") ("tockInitChanArray(foo_storage,foo_actual,4*5*6);","") $ + ,testAll 5 ("tock_init_chan_array(foo_storage,foo,4*5*6);^ChanInit(wptr,foo[0*foo_sizes[1]*foo_sizes[2]]);^","") ("tockInitChanArray(foo_storage,foo_actual,4*5*6);","") $ A.Array [A.Dimension 4,A.Dimension 5,A.Dimension 6] $ A.Chan A.DirUnknown (A.ChanAttributes False False) A.Int ,testAllSame 6 ("","") $ A.Array [A.Dimension 4] $ A.Chan A.DirInput (A.ChanAttributes False False) A.Int @@ -889,7 +889,7 @@ testCase = TestList over = local $ \ops -> ops {genExpression = override1 dollar, genProcess = override1 at, genStop = override2 caret, genSpec = override2 hash} testGetTime :: Test -testGetTime = testBoth "testGetTime 0" "ProcTime(&@);" "csp::CurrentTime(&@);" (over (tcall2 genGetTime emptyMeta undefined)) +testGetTime = testBoth "testGetTime 0" "@ = TimerRead(wptr);" "csp::CurrentTime(&@);" (over (tcall genGetTime undefined)) where over :: Override over = local $ \ops -> ops {genVariable = override1 at} @@ -897,8 +897,8 @@ testGetTime = testBoth "testGetTime 0" "ProcTime(&@);" "csp::CurrentTime(&@);" ( testWait :: Test testWait = TestList [ - testBoth "testWait 0" "ProcTimeAfter($);" "csp::SleepUntil($);" (over (tcall2 genWait A.WaitUntil undefined)) - ,testBoth "testWait 1" "ProcAfter($);" "csp::SleepFor($);" (over (tcall2 genWait A.WaitFor undefined)) + testBoth "testWait 0" "TimerWait(wptr,$);" "csp::SleepUntil($);" (over (tcall2 genWait A.WaitUntil undefined)) + ,testBoth "testWait 1" "TimerDelay(wptr,$);" "csp::SleepFor($);" (over (tcall2 genWait A.WaitFor undefined)) ] where over :: Override @@ -936,43 +936,43 @@ testInput = TestList ,testBothSame "testInput 2" "^^^" (overInputItemCase (tcall2 genInput undefined $ A.InputSimple undefined [undefined, undefined, undefined])) -- Reading an integer (special case in the C backend): - ,testInputItem 100 "ChanInInt(#,&x);" "#>>x;" (A.InVariable emptyMeta $ variable "x") A.Int + ,testInputItem 100 "ChanInInt(wptr,#,&x);" "#>>x;" (A.InVariable emptyMeta $ variable "x") A.Int -- Reading a other plain types: - ,testInputItem 101 "ChanIn(#,&x,^(Int8));" "#>>x;" (A.InVariable emptyMeta $ variable "x") A.Int8 - ,testInputItem 102 ("ChanIn(#,(&x),^(" ++ show (A.Record foo) ++ "));") "#>>*(&x);" (A.InVariable emptyMeta $ variable "x") (A.Record foo) + ,testInputItem 101 "ChanIn(wptr,#,&x,^(Int8));" "#>>x;" (A.InVariable emptyMeta $ variable "x") A.Int8 + ,testInputItem 102 ("ChanIn(wptr,#,(&x),^(" ++ show (A.Record foo) ++ "));") "#>>*(&x);" (A.InVariable emptyMeta $ variable "x") (A.Record foo) -- Reading into a fixed size array: - ,testInputItem 103 "ChanIn(#,x,^(Array [Dimension 8] Int));" "tockRecvArray(#,x);" (A.InVariable emptyMeta $ variable "x") $ A.Array [A.Dimension 8] A.Int + ,testInputItem 103 "ChanIn(wptr,#,x,^(Array [Dimension 8] Int));" "tockRecvArray(#,x);" (A.InVariable emptyMeta $ variable "x") $ A.Array [A.Dimension 8] A.Int -- Reading into subscripted variables: - ,testInputItem 110 "ChanInInt(#,&xs$);" "#>>xs$;" (A.InVariable emptyMeta $ sub0 $ variable "xs") A.Int + ,testInputItem 110 "ChanInInt(wptr,#,&xs$);" "#>>xs$;" (A.InVariable emptyMeta $ sub0 $ variable "xs") A.Int -- Reading a other plain types: - ,testInputItem 111 "ChanIn(#,&xs$,^(Int8));" "#>>xs$;" (A.InVariable emptyMeta $ sub0 $ variable "xs") A.Int8 - ,testInputItem 112 ("ChanIn(#,(&xs$),^(" ++ show (A.Record foo) ++ "));") "#>>*(&xs$);" (A.InVariable emptyMeta $ sub0 $ variable "xs") (A.Record foo) + ,testInputItem 111 "ChanIn(wptr,#,&xs$,^(Int8));" "#>>xs$;" (A.InVariable emptyMeta $ sub0 $ variable "xs") A.Int8 + ,testInputItem 112 ("ChanIn(wptr,#,(&xs$),^(" ++ show (A.Record foo) ++ "));") "#>>*(&xs$);" (A.InVariable emptyMeta $ sub0 $ variable "xs") (A.Record foo) -- A counted array of Int: - ,testInputItem 200 "ChanInInt(#,&x);ChanIn(#,xs,x*^(Int));" + ,testInputItem 200 "ChanInInt(wptr,#,&x);ChanIn(wptr,#,xs,x*^(Int));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int),&x));tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(x*^(Int),xs));" (A.InCounted emptyMeta (variable "x") (variable "xs")) (A.Counted A.Int A.Int) -- A counted array, counted by Int8: - ,testInputItem 201 "ChanIn(#,&x,^(Int8));ChanIn(#,xs,x*^(Int));" + ,testInputItem 201 "ChanIn(wptr,#,&x,^(Int8));ChanIn(wptr,#,xs,x*^(Int));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int8),&x));tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(x*^(Int),xs));" (A.InCounted emptyMeta (variable "x") (variable "xs")) (A.Counted A.Int8 A.Int) -- TODO reading in a counted/fixed-size array into an array of arrays (or will that have already been sliced?) -- inputs as part of protocols/any: - ,testInputItemProt 300 "ChanInInt(#,&x);" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int),&x));" + ,testInputItemProt 300 "ChanInInt(wptr,#,&x);" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int),&x));" (A.InVariable emptyMeta $ variable "x") A.Int - ,testInputItemProt 301 "ChanIn(#,&x,^(Int8));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int8),&x));" + ,testInputItemProt 301 "ChanIn(wptr,#,&x,^(Int8));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int8),&x));" (A.InVariable emptyMeta $ variable "x") A.Int8 - ,testInputItemProt 302 ("ChanIn(#,(&x),^(" ++ show (A.Record foo) ++ "));") ("tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(" ++ show (A.Record foo) ++ "),(&x)));") + ,testInputItemProt 302 ("ChanIn(wptr,#,(&x),^(" ++ show (A.Record foo) ++ "));") ("tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(" ++ show (A.Record foo) ++ "),(&x)));") (A.InVariable emptyMeta $ variable "x") (A.Record foo) - ,testInputItemProt 303 "ChanIn(#,x,^(Array [Dimension 8] Int));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Array [Dimension 8] Int),x));" + ,testInputItemProt 303 "ChanIn(wptr,#,x,^(Array [Dimension 8] Int));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Array [Dimension 8] Int),x));" (A.InVariable emptyMeta $ variable "x") $ A.Array [A.Dimension 8] A.Int - ,testInputItemProt 400 "ChanInInt(#,&x);ChanIn(#,xs,x*^(Int));" + ,testInputItemProt 400 "ChanInInt(wptr,#,&x);ChanIn(wptr,#,xs,x*^(Int));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int),&x));tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(x*^(Int),xs));" (A.InCounted emptyMeta (variable "x") (variable "xs")) (A.Counted A.Int A.Int) - ,testInputItemProt 401 "ChanIn(#,&x,^(Int8));ChanIn(#,xs,x*^(Int8));" + ,testInputItemProt 401 "ChanIn(wptr,#,&x,^(Int8));ChanIn(wptr,#,xs,x*^(Int8));" "tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(^(Int8),&x));tockRecvArrayOfBytes(#,tockSendableArrayOfBytes(x*^(Int8),xs));" (A.InCounted emptyMeta (variable "x") (variable "xs")) (A.Counted A.Int8 A.Int8) @@ -1020,46 +1020,46 @@ testOutput = TestList ,testBothSame "testOutput 1" "^" (overOutputItem (tcall2 genOutput undefined [undefined])) ,testBothSame "testOutput 2" "^^^" (overOutputItem (tcall2 genOutput undefined [undefined,undefined,undefined])) - ,testBothS "testOutput 100" "ChanOutInt((&c),bar_foo);^" "tockSendInt((&c)->writer(),bar_foo);^" (overOutput (tcall3 genOutputCase (A.Variable emptyMeta chan) bar [])) state - ,testBothS "testOutput 101" "ChanOutInt(cOut,bar_foo);^" "tockSendInt(cOut,bar_foo);^" (overOutput (tcall3 genOutputCase (A.Variable emptyMeta chanOut) bar [])) state + ,testBothS "testOutput 100" "ChanOutInt(wptr,(&c),bar_foo);^" "tockSendInt((&c)->writer(),bar_foo);^" (overOutput (tcall3 genOutputCase (A.Variable emptyMeta chan) bar [])) state + ,testBothS "testOutput 101" "ChanOutInt(wptr,cOut,bar_foo);^" "tockSendInt(cOut,bar_foo);^" (overOutput (tcall3 genOutputCase (A.Variable emptyMeta chanOut) bar [])) state --Integers are a special case in the C backend: - ,testOutputItem 201 "ChanOutInt(#,x);" "#< do t <- typeOfExpression e - count <- evalIntExpression $ sizeOfReplicator rep + count <- evalIntExpression $ countReplicator rep typeOfArrayList [A.Dimension count] t A.AllocMobile _ t _ -> return t --}}} @@ -577,20 +577,24 @@ bytesInType _ = return $ BIUnknown --}}} -- | Get the number of items a replicator produces. -sizeOfReplicator :: A.Replicator -> A.Expression -sizeOfReplicator (A.For _ _ _ count) = count +countReplicator :: A.Replicator -> A.Expression +countReplicator (A.For _ _ _ count) = count -- | Get the number of items in a Structured as an expression. -sizeOfStructured :: Data a => A.Structured a -> A.Expression -sizeOfStructured (A.Rep m rep s) - = A.Dyadic m A.Times (sizeOfReplicator rep) (sizeOfStructured s) -sizeOfStructured (A.Spec _ _ s) = sizeOfStructured s -sizeOfStructured (A.ProcThen _ _ s) = sizeOfStructured s -sizeOfStructured (A.Several m ss) +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.Rep m rep s) + = A.Dyadic m A.Times (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 (A.Dyadic m A.Plus) (map sizeOfStructured ss) -sizeOfStructured s = makeConstant (findMeta s) 1 + _ -> foldl1 (A.Dyadic m A.Plus) (map (computeStructured f) ss) -- | Add one to an expression. addOne :: A.Expression -> A.Expression