{-
Tock: a compiler for parallel languages
Copyright (C) 2007, 2008 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.List
import qualified AST as A
import CompState
import Metadata
import Pass
import qualified Properties as Prop
import Traversal
import Types
import Utils
simplifyComms :: [Pass A.AST]
simplifyComms =
[ outExprs
, transformInputCase
, transformProtocolInput
]
outExprs :: PassOn A.Process
outExprs = pass "Define temporary variables for outputting expressions"
(Prop.agg_namesDone ++ Prop.agg_typesDone)
[Prop.outExpressionRemoved]
(applyBottomUpM doProcess)
where
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 = return 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 <- astTypeOf e
specification@(A.Specification _ nm _) <-
defineNonce m "output_var" (A.Is m A.ValAbbrev t $
A.ActualExpression e) 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 :: PassOn A.Process
transformInputCase = pass "Transform ? CASE statements/guards into plain CASE"
(Prop.agg_namesDone ++ Prop.agg_typesDone)
[Prop.inputCaseRemoved]
(applyBottomUpM doProcess)
where
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) 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 = return p
-- Convert Structured Variant into the equivalent Structured Option.
doStructuredV :: A.Variable -> A.Structured A.Variant -> PassM (A.Structured A.Option)
doStructuredV chanVar = transformOnly transform
where
transform m (A.Variant m' n iis p)
= do (Right items) <- protocolItems m' chanVar
let (Just idx) = elemIndex n (fst $ unzip items)
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]
-- Transform alt guards.
doStructuredA :: A.Structured A.Alternative -> PassM (A.Structured A.Alternative)
doStructuredA = transformOnly doAlternative
where
-- The processes that are the body of input-case guards are always
-- skip, so we can discard them.
doAlternative m (A.Alternative m' e v (A.InputCase m'' s) _)
= do spec@(A.Specification _ n _) <- defineNonce m "input_tag" (A.Declaration m' A.Int) A.Original
s' <- doStructuredV v s
return $ A.Spec m' spec $ A.Only m $
A.Alternative 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 untouched.
doAlternative m a = return $ A.Only m a
transformProtocolInput :: PassOn2 A.Process A.Alternative
transformProtocolInput = pass "Flatten sequential protocol inputs into multiple inputs"
(Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.inputCaseRemoved])
[Prop.seqInputsFlattened]
(applyBottomUpM2 doProcess doAlternative)
where
doProcess :: A.Process -> PassM A.Process
doProcess (A.Input m v (A.InputSimple m' iis@(_:_:_)))
= return $ A.Seq m $ A.Several m $
map (A.Only m . A.Input m v . A.InputSimple m' . singleton) iis
doProcess p = return p
doAlternative :: A.Alternative -> PassM A.Alternative
doAlternative (A.Alternative m cond v (A.InputSimple m' (firstII:(otherIIS@(_:_)))) body)
= return $ A.Alternative m cond v (A.InputSimple m' [firstII]) $ A.Seq m' $ A.Several m' $
map (A.Only m' . A.Input m' v . A.InputSimple m' . singleton) otherIIS
++ [A.Only m' body]
doAlternative s = return s