acd57d74de
This patch is actually an amalgam of multiple (already large) patches. Those patches conflicted (parameterised Structured vs. changes to usage checking and FlowGraph) and encountered a nasty bug in darcs 1 involving exponential time (see http://wiki.darcs.net/DarcsWiki/ConflictsFAQ for more details). Reasoning that half an hour (of 100% CPU use) was too long to apply patches, I opted to re-record the parameterised Structured changes as this new large patch. Here are the commit messages originally used for the patches (which, as mentioned, were already large patches): A gigantic patch switching all the non-test modules over to using parameterised A.Structured Changed the FlowGraph module again to handle any sort of Structured you want to pass to it (mainly for testing) A further gigantic patch changing all the tests to work with the new parameterised Structured Fixed a nasty bug involving functions being named incorrectly inside transformInputCase Added a hand-written instance of Data for Structured that allows us to use ext1M properly Fixed a few warnings in the code
216 lines
8.4 KiB
Haskell
216 lines
8.4 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 2007 University of Kent
|
|
|
|
This program is free software; you can redistribute it and/or modify it
|
|
under the terms of the GNU General Public License as published by the
|
|
Free Software Foundation, either version 2 of the License, or (at your
|
|
option) any later version.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License along
|
|
with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
-}
|
|
|
|
-- | Simplify communications.
|
|
module SimplifyComms where
|
|
|
|
import Control.Monad.State
|
|
import Data.Generics
|
|
import Data.List
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Metadata
|
|
import Pass
|
|
import Types
|
|
import Utils
|
|
|
|
simplifyComms :: Pass
|
|
simplifyComms = runPasses passes
|
|
where
|
|
passes :: [(String, Pass)]
|
|
passes =
|
|
[ ("Define temporary variables for outputting expressions", outExprs)
|
|
,("Transform ? CASE statements/guards into plain CASE", transformInputCase)
|
|
]
|
|
|
|
outExprs :: Data t => t -> PassM t
|
|
outExprs = doGeneric `extM` doProcess
|
|
where
|
|
doGeneric :: Data t => t -> PassM t
|
|
doGeneric = makeGeneric outExprs
|
|
|
|
doProcess :: A.Process -> PassM A.Process
|
|
doProcess (A.Output m c ois)
|
|
= do (ois', specs) <- mapAndUnzipM changeItem ois
|
|
let foldedSpec = foldFuncs specs
|
|
return $ A.Seq m (foldedSpec $ A.Only m $ A.Output m c ois')
|
|
doProcess (A.OutputCase m c tag ois)
|
|
= do (ois', specs) <- mapAndUnzipM changeItem ois
|
|
let foldedSpec = foldFuncs specs
|
|
return $ A.Seq m (foldedSpec $ A.Only m $ A.OutputCase m c tag ois')
|
|
doProcess p = doGeneric p
|
|
|
|
changeItem :: A.OutputItem -> PassM (A.OutputItem, A.Structured A.Process -> A.Structured A.Process)
|
|
changeItem (A.OutExpression m e) = do (e', spec) <- transExpr m e
|
|
return (A.OutExpression m e', spec)
|
|
changeItem (A.OutCounted m ce ae) = do (ce', ceSpec) <- transExpr m ce
|
|
(ae', aeSpec) <- transExpr m ae
|
|
return (A.OutCounted m ce' ae', ceSpec . aeSpec)
|
|
|
|
transExpr :: Meta -> A.Expression -> PassM (A.Expression, A.Structured A.Process -> A.Structured A.Process)
|
|
-- If it's already an output direct from a variable, no need to change it:
|
|
transExpr _ e@(A.ExprVariable {}) = return (e, id)
|
|
transExpr m e = do (nm, spec) <- abbrevExpr m e
|
|
return (A.ExprVariable m $ A.Variable m nm, spec)
|
|
|
|
abbrevExpr :: Meta -> A.Expression -> PassM (A.Name, A.Structured A.Process -> A.Structured A.Process)
|
|
abbrevExpr m e = do t <- typeOfExpression e
|
|
specification@(A.Specification _ nm _) <- defineNonce m "output_var" (A.IsExpr m A.ValAbbrev t e) A.VariableName A.ValAbbrev
|
|
return (nm, A.Spec m specification)
|
|
|
|
{- The explanation for this pass is taken from my (Neil's) mailing list post "Case protocols" on tock-discuss, dated 10th October 2007:
|
|
|
|
Currently in Tock (from occam) we have CASE statements, and inputs for variant
|
|
protocols. They are parsed into separate AST entries, which is sensible. But
|
|
then in the backend there is some duplicate code because both things get turned
|
|
into some form of switch statement. It would be straightforward to unify the
|
|
code in the C/C++ backends, but I was wondering about doing something which
|
|
would be a bit cleaner; unifying them in an earlier pass (everything should be
|
|
a pass in nanopass :). The idea would be to turn (example is from the occam 2
|
|
manual):
|
|
|
|
from.dfs ? CASE
|
|
record; rnumber; rlen::buffer
|
|
-- process A
|
|
error ; enumber; elen::buffer
|
|
-- process B
|
|
|
|
into:
|
|
|
|
INT temp.var:
|
|
SEQ
|
|
from.dfs ? temp.var
|
|
CASE temp.var
|
|
3
|
|
SEQ
|
|
from.dfs ? rnumber ; rlen::buffer
|
|
-- process A
|
|
4
|
|
SEQ
|
|
from.dfs ? enumber ; elen::buffer
|
|
-- process B
|
|
|
|
Note that the tags are turned into integer literals, which is what happens in
|
|
Tock already anyway. Note that in Tock each protocol item is already a
|
|
separate communication, so splitting out the sequential inputs is fine. ALTs
|
|
would have to be split as follows, by turning:
|
|
|
|
ALT
|
|
from.dfs ? CASE
|
|
request ; query
|
|
-- process C
|
|
error ; enumber; elen::buffer
|
|
-- process D
|
|
|
|
into:
|
|
|
|
ALT
|
|
INT temp.var:
|
|
from.dfs ? temp.var
|
|
CASE temp.var
|
|
0
|
|
SEQ
|
|
from.dfs ? query
|
|
-- process C
|
|
1
|
|
SEQ
|
|
from.dfs ? enumber ; elen::buffer
|
|
-- process D
|
|
-}
|
|
|
|
transformInputCase :: Data t => t -> PassM t
|
|
transformInputCase = doGeneric `extM` doProcess
|
|
where
|
|
doGeneric :: Data t => t -> PassM t
|
|
doGeneric = makeGeneric transformInputCase
|
|
|
|
doProcess :: A.Process -> PassM A.Process
|
|
doProcess (A.Input m v (A.InputCase m' s))
|
|
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int Nothing) A.VariableName A.Original
|
|
s' <- doStructuredV v s
|
|
return $ A.Seq m $ A.Spec m' spec $ A.Several m'
|
|
[A.Only m $ A.Input m v (A.InputSimple m [A.InVariable m (A.Variable m n)])
|
|
,A.Only m' $ A.Case m' (A.ExprVariable m $ A.Variable m n) s']
|
|
doProcess (A.Alt m pri s)
|
|
= do s' <- doStructuredA s
|
|
return (A.Alt m pri s')
|
|
doProcess p = doGeneric p
|
|
|
|
-- Can't easily use generics here as we're switching from one type of Structured to another
|
|
doStructuredV :: A.Variable -> A.Structured A.Variant -> PassM (A.Structured A.Option)
|
|
-- These entries all just burrow deeper into the structured:
|
|
doStructuredV v (A.ProcThen m p s)
|
|
= do s' <- doStructuredV v s
|
|
p' <- doProcess p
|
|
return (A.ProcThen m p' s')
|
|
doStructuredV v (A.Spec m sp st)
|
|
= do st' <- doStructuredV v st
|
|
return (A.Spec m sp st')
|
|
doStructuredV v (A.Several m ss)
|
|
= do ss' <- mapM (doStructuredV v) ss
|
|
return (A.Several m ss')
|
|
doStructuredV v (A.Rep m rep s)
|
|
= do s' <- doStructuredV v s
|
|
return (A.Rep m rep s')
|
|
-- Transform variant options:
|
|
doStructuredV chanVar (A.Only m (A.Variant m' n iis p))
|
|
= do (Right items) <- protocolItems chanVar
|
|
let (Just idx) = elemIndex n (fst $ unzip items)
|
|
p' <- doProcess p
|
|
return $ A.Only m $ A.Option m' [makeConstant m' idx] $
|
|
if (length iis == 0)
|
|
then p'
|
|
else A.Seq m' $ A.Several m'
|
|
[A.Only m' $ A.Input m' chanVar (A.InputSimple m' iis)
|
|
,A.Only (findMeta p') p']
|
|
|
|
doStructuredA :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative)
|
|
-- TODO use generics instead of this boilerplate, but don't omit the doProcess call in ProcThen!
|
|
doStructuredA (A.ProcThen m p s)
|
|
= do s' <- doStructuredA s
|
|
p' <- doProcess p
|
|
return (A.ProcThen m p' s')
|
|
doStructuredA (A.Spec m sp st)
|
|
= do st' <- doStructuredA st
|
|
return (A.Spec m sp st')
|
|
doStructuredA (A.Several m ss)
|
|
= do ss' <- mapM doStructuredA ss
|
|
return (A.Several m ss')
|
|
doStructuredA (A.Rep m rep s)
|
|
= do s' <- doStructuredA s
|
|
return (A.Rep m rep s')
|
|
|
|
-- Transform alt guards:
|
|
-- The processes that are the body of input-case guards are always skip, so we can discard them:
|
|
doStructuredA (A.Only m (A.Alternative m' v (A.InputCase m'' s) _))
|
|
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int Nothing) A.VariableName A.Original
|
|
s' <- doStructuredV v s
|
|
return $ A.Spec m' spec $ A.Only m $
|
|
A.Alternative m' v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $
|
|
A.Case m'' (A.ExprVariable m'' $ A.Variable m n) s'
|
|
doStructuredA (A.Only m (A.AlternativeCond m' e v (A.InputCase m'' s) _))
|
|
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int Nothing) A.VariableName A.Original
|
|
s' <- doStructuredV v s
|
|
return $ A.Spec m' spec $ A.Only m $
|
|
A.AlternativeCond m' e v (A.InputSimple m [A.InVariable m (A.Variable m n)]) $
|
|
A.Case m'' (A.ExprVariable m'' $ A.Variable m n) s'
|
|
-- Leave other guards (and parts of Structured) untouched:
|
|
doStructuredA s = return s
|
|
|