Fixed all the nasty hacks from earlier relating to running processes in parallel

This commit is contained in:
Neil Brown 2009-03-27 21:35:28 +00:00
parent a71e2a8c0a
commit ecc42f704d

View File

@ -1550,7 +1550,7 @@ prefixComma :: [CGen ()] -> CGen ()
prefixComma cs = sequence_ [genComma >> c | c <- cs] prefixComma cs = sequence_ [genComma >> c | c <- cs]
cgenActuals :: [A.Formal] -> [A.Actual] -> CGen () cgenActuals :: [A.Formal] -> [A.Actual] -> CGen ()
cgenActuals fs as = prefixComma [call genActual f a | (f, a) <- zip fs as] cgenActuals fs as = seqComma [call genActual f a | (f, a) <- zip fs as]
cgenActual :: A.Formal -> A.Actual -> CGen () cgenActual :: A.Formal -> A.Actual -> CGen ()
cgenActual f a = seqComma $ realActuals f a id cgenActual f a = seqComma $ realActuals f a id
@ -1898,29 +1898,27 @@ cgenWhile e p
-- the same as PAR. -- the same as PAR.
cgenPar :: A.ParMode -> A.Structured A.Process -> CGen () cgenPar :: A.ParMode -> A.Structured A.Process -> CGen ()
cgenPar pm s cgenPar pm s
= do (count, _, _) <- constantFold $ countStructured s = do bar <- csmLift $ makeNonce "par_barrier"
tell ["LightProcBarrier ", bar, ";"]
bar <- csmLift $ makeNonce "par_barrier" let count = countStructured s
tell ["LightProcBarrier ", bar, ";\n"]
wss <- csmLift $ makeNonce "wss" wss <- csmLift $ makeNonce "wss"
tell ["Workspace ", wss, "[1024];int ", wss, "_count = 0;"] -- Hack! tell ["Workspace* ",wss,"=(Workspace*)malloc(sizeof(int)*"]
-- Dynamic parallel replicator counts are declared inside the parallel,
-- but we need to access it here. This hack may do it, but need a better
-- solution in future!
tell ["{"]
call genStructured s (const return)
tell ["LightProcBarrierInit (wptr, &", bar, ", "]
call genExpression count call genExpression count
tell [");\n"] tell [");"]
tell ["}"] tell ["int ",wss,"_count=0;"]
tell ["LightProcBarrierInit(wptr,&", bar, ","]
call genExpression count
tell [");"]
call genStructured s (startP bar wss) call genStructured s (startP bar wss)
tell ["LightProcBarrierWait (wptr, &", bar, ");\n"] tell ["LightProcBarrierWait (wptr, &", bar, ");\n"]
tell ["{int i;for (i = 0;i < ", wss, "_count;i++)" tell ["{int i;for(i=0;i<"]
,"{TockProcFree(wptr, ", wss, "[i]);}}"] call genExpression count
tell [";i++){TockProcFree(wptr, ", wss, "[i]);}}"]
tell ["free(", wss, ");"]
where where
startP :: String -> String -> Meta -> A.Process -> CGen () startP :: String -> String -> Meta -> A.Process -> CGen ()
startP bar wss _ (A.ProcCall _ n as) startP bar wss _ (A.ProcCall _ n as)
@ -1928,9 +1926,8 @@ cgenPar pm s
(ws, func) <- cgenProcAlloc n fs as (ws, func) <- cgenProcAlloc n fs as
tell ["LightProcStart (wptr, &", bar, ", ", ws, ", "] tell ["LightProcStart (wptr, &", bar, ", ", ws, ", "]
func func
tell [");\n"] tell [");"]
tell [wss,"[",wss,"_count++]=", ws,";"] tell [wss,"[",wss,"_count++]=", ws,";"]
return ()
--}}} --}}}
--{{{ alt --{{{ alt
cgenAlt :: Bool -> A.Structured A.Alternative -> CGen () cgenAlt :: Bool -> A.Structured A.Alternative -> CGen ()
@ -2052,18 +2049,23 @@ cgenProcCall n as
let m = A.nameMeta n let m = A.nameMeta n
in call genPar A.PlainPar $ A.Only m $ A.ProcCall m n as in call genPar A.PlainPar $ A.Only m $ A.ProcCall m n as
(_, Just _) -> (_, Just _) ->
do tell ["{int args_plus_blank[] = {0"] do let (c:cs) = A.nameName n
-- We don't use the formals in externals because they won't tell ["{int ext_args[] = {"]
-- We don't use the formals in csExternals because they won't
-- have had array sizes added: -- have had array sizes added:
(A.Proc _ _ fs _) <- specTypeOfName n (A.Proc _ _ fs _) <- specTypeOfName n
liftIO $ putStrLn $ show (fs, as)
call genActuals fs as call genActuals fs as
tell ["};"] tell ["};"]
let (_:cs) = A.nameName n
tell [[if c == '.' then '_' else c | c <- cs]] case c of
tell ["(&(args_plus_blank[1]));}"] 'B' -> tell ["ExternalCallN("]
'C' -> tell ["BlockingCallN(wptr,"]
_ -> dieP (A.nameMeta n) "Unknown external PROC format"
tell [ [if c == '.' then '_' else c | c <- cs]
, ",1,ext_args);}"]
_ -> do genName n _ -> do genName n
tell [" (wptr"] tell [" (wptr,"]
(A.Proc _ _ fs _) <- specTypeOfName n (A.Proc _ _ fs _) <- specTypeOfName n
call genActuals fs as call genActuals fs as
tell [");\n"] tell [");\n"]