6debf9292f
This changes the Traversal API to the one that I've been working on in the Polyplate branch, but implemented in terms of Data. The performance isn't as good as the Polyplate version, but the code is a lot simpler because it doesn't need all the type constraints (and it doesn't make GHC struggle). This also reworks all the passes in Tock to use the new API, including those that previously used makeGeneric (which I've now removed) or everywhereM. Most of the passes are simpler because of this, and I suspect it's fixed a few subtle bugs resulting from missing recursion in makeGeneric code. I haven't yet profiled this, but subjectively it seems about the same as the old Traversal (and thus faster for all the passes that didn't yet use it).
402 lines
18 KiB
Haskell
402 lines
18 KiB
Haskell
{-
|
|
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 expressions in the AST.
|
|
module SimplifyExprs where
|
|
|
|
import Control.Monad.State
|
|
import Data.Generics
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Errors
|
|
import EvalConstants
|
|
import Metadata
|
|
import Pass
|
|
import qualified Properties as Prop
|
|
import ShowCode
|
|
import Traversal
|
|
import Types
|
|
import Utils
|
|
|
|
simplifyExprs :: [Pass]
|
|
simplifyExprs = makePassesDep
|
|
[ ("Convert FUNCTIONs to PROCs", functionsToProcs, Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.parUsageChecked,
|
|
Prop.functionTypesChecked], [Prop.functionsRemoved])
|
|
, ("Convert AFTER to MINUS", removeAfter, [Prop.expressionTypesChecked], [Prop.afterRemoved])
|
|
, ("Expand array literals", expandArrayLiterals, [Prop.expressionTypesChecked, Prop.processTypesChecked], [Prop.arrayLiteralsExpanded])
|
|
, ("Pull up replicator counts for SEQs", pullRepCounts, Prop.agg_namesDone ++ Prop.agg_typesDone, [])
|
|
, ("Pull up definitions", pullUp False, Prop.agg_namesDone ++ Prop.agg_typesDone ++ [Prop.functionsRemoved, Prop.seqInputsFlattened], [Prop.functionCallsRemoved, Prop.subscriptsPulledUp])
|
|
, ("Transform array constructors into initialisation code", transformConstr, Prop.agg_namesDone ++ Prop.agg_typesDone
|
|
++ [Prop.subscriptsPulledUp], [Prop.arrayConstructorsRemoved])
|
|
]
|
|
-- ++ makePassesDep' ((== BackendCPPCSP) . csBackend) [("Pull up definitions (C++)", pullUp True, Prop.agg_namesDone ++ [Prop.expressionTypesChecked, Prop.functionsRemoved, Prop.processTypesChecked,Prop.seqInputsFlattened], [Prop.functionCallsRemoved, Prop.subscriptsPulledUp])]
|
|
|
|
-- | Convert FUNCTION declarations to PROCs.
|
|
functionsToProcs :: PassType
|
|
functionsToProcs = applyDepthM doSpecification
|
|
where
|
|
doSpecification :: A.Specification -> PassM A.Specification
|
|
doSpecification (A.Specification m n (A.Function mf sm rts fs evp))
|
|
= do -- Create new names for the return values.
|
|
specs <- sequence [makeNonceVariable "return_formal" mf t A.VariableName A.Abbrev | t <- rts]
|
|
let names = [n | A.Specification mf n _ <- specs]
|
|
-- Note the return types so we can fix calls later.
|
|
modify $ (\ps -> ps { csFunctionReturns = Map.insert (A.nameName n) rts (csFunctionReturns ps) })
|
|
-- Turn the value process into an assignment process.
|
|
let p = vpToSeq m n evp [A.Variable mf n | n <- names]
|
|
let st = A.Proc mf sm (fs ++ [A.Formal A.Abbrev t n | (t, n) <- zip rts names]) p
|
|
-- Build a new specification and redefine the function.
|
|
let spec = A.Specification m n st
|
|
let nd = A.NameDef {
|
|
A.ndMeta = mf,
|
|
A.ndName = A.nameName n,
|
|
A.ndOrigName = A.nameName n,
|
|
A.ndNameType = A.ProcName,
|
|
A.ndSpecType = st,
|
|
A.ndAbbrevMode = A.Original,
|
|
A.ndPlacement = A.Unplaced
|
|
}
|
|
defineName n nd
|
|
return spec
|
|
doSpecification s = return s
|
|
|
|
vpToSeq :: Meta -> A.Name -> Either (A.Structured A.ExpressionList) A.Process -> [A.Variable] -> A.Process
|
|
vpToSeq m n (Left el) vs = A.Seq m $ vpToSeq' el vs
|
|
vpToSeq _ n (Right p) vs = subst p
|
|
where
|
|
subst :: Data t => t -> t
|
|
subst = doGenericSubst `extT` doAssignSubst
|
|
|
|
doGenericSubst :: Data t => t -> t
|
|
doGenericSubst = gmapT subst `extT` (id :: String -> String) `extT` (id :: Meta -> Meta)
|
|
|
|
doAssignSubst :: A.Process -> A.Process
|
|
doAssignSubst ass@(A.Assign m [A.Variable _ dest] el) = if (A.nameName dest == A.nameName n) then (A.Assign m vs el) else ass
|
|
doAssignSubst p = doGenericSubst p
|
|
|
|
|
|
vpToSeq' :: A.Structured A.ExpressionList -> [A.Variable] -> A.Structured A.Process
|
|
vpToSeq' (A.Spec m spec s) vs = A.Spec m spec (vpToSeq' s vs)
|
|
vpToSeq' (A.ProcThen m p s) vs = A.ProcThen m p (vpToSeq' s vs)
|
|
vpToSeq' (A.Only m el) vs = A.Only m $ A.Assign m vs el
|
|
|
|
-- | Convert AFTER expressions to the equivalent using MINUS (which is how the
|
|
-- occam 3 manual defines AFTER).
|
|
removeAfter :: PassType
|
|
removeAfter = applyDepthM doExpression
|
|
where
|
|
doExpression :: A.Expression -> PassM A.Expression
|
|
doExpression (A.Dyadic m A.After a b)
|
|
= do t <- astTypeOf a
|
|
case t of
|
|
A.Byte -> do let one = A.Literal m t $ A.IntLiteral m "1"
|
|
oneTwoSeven = A.Literal m t $ A.IntLiteral m "127"
|
|
return $ A.Dyadic m A.Less (A.Dyadic m A.Minus (A.Dyadic m A.Minus a b) one) oneTwoSeven
|
|
_ -> do let zero = A.Literal m t $ A.IntLiteral m "0"
|
|
return $ A.Dyadic m A.More (A.Dyadic m A.Minus a b) zero
|
|
doExpression e = return e
|
|
|
|
-- | For array literals that include other arrays, burst them into their
|
|
-- elements.
|
|
expandArrayLiterals :: PassType
|
|
expandArrayLiterals = applyDepthM doArrayElem
|
|
where
|
|
doArrayElem :: A.ArrayElem -> PassM A.ArrayElem
|
|
doArrayElem ae@(A.ArrayElemExpr e)
|
|
= do t <- astTypeOf e
|
|
case t of
|
|
A.Array ds _ -> expand ds e
|
|
_ -> return ae
|
|
doArrayElem ae = return ae
|
|
|
|
expand :: [A.Dimension] -> A.Expression -> PassM A.ArrayElem
|
|
expand [] e = return $ A.ArrayElemExpr e
|
|
expand (A.UnknownDimension:_) e
|
|
= dieP (findMeta e) "array literal containing non-literal array of unknown size"
|
|
expand (A.Dimension n:ds) e
|
|
= do -- Because it's an array literal, we must know the size.
|
|
size <- evalIntExpression n
|
|
elems <- sequence [expand ds (A.SubscriptedExpr m
|
|
(A.Subscript m A.NoCheck $
|
|
makeConstant m i) e)
|
|
| i <- [0 .. size - 1]]
|
|
return $ A.ArrayElemArray elems
|
|
where m = findMeta e
|
|
|
|
-- | We pull up the loop (Rep) counts into a temporary expression, whenever the loop
|
|
-- count could be modified within the loop. Here are all things that can be replicated:
|
|
-- SEQ -- can be altered during the loop, must pull up
|
|
-- PAR -- count cannot be modified by code inside the loop (it is used before any PAR branches are run)
|
|
-- IF -- cannot be altered during loop; once body executes, loop is effectively broken
|
|
-- ALT -- same as IF
|
|
-- Therefore, we only need to pull up the counts for sequential replicators
|
|
--
|
|
-- TODO for simplification, we could avoid pulling up replication counts that are known to be constants
|
|
pullRepCounts :: PassType
|
|
pullRepCounts = applyDepthM doProcess
|
|
where
|
|
doProcess :: A.Process -> PassM A.Process
|
|
doProcess (A.Seq m s) = pullRepCountSeq s >>* A.Seq m
|
|
doProcess p = return p
|
|
|
|
pullRepCountSeq :: A.Structured A.Process -> PassM (A.Structured A.Process)
|
|
pullRepCountSeq s@(A.Only _ _) = return s
|
|
pullRepCountSeq (A.Spec m sp str)
|
|
= do str' <- pullRepCountSeq str
|
|
return $ A.Spec m sp str'
|
|
pullRepCountSeq (A.ProcThen m p s)
|
|
= do s' <- pullRepCountSeq s
|
|
return $ A.ProcThen m p s'
|
|
pullRepCountSeq (A.Several m ss) = mapM pullRepCountSeq ss >>* A.Several m
|
|
pullRepCountSeq (A.Rep m (A.For m' n from for) s)
|
|
= do t <- astTypeOf for
|
|
spec@(A.Specification _ nonceName _) <- makeNonceIsExpr "rep_for" m' t for
|
|
s' <- pullRepCountSeq s
|
|
return $ A.Spec m spec $ A.Rep m (A.For m' n from (A.ExprVariable m' $ A.Variable m' nonceName)) s'
|
|
-- Other replicators (such as ForEach)
|
|
pullRepCountSeq (A.Rep m rep s)
|
|
= do s' <- pullRepCountSeq s
|
|
return $ A.Rep m rep s'
|
|
|
|
transformConstr :: PassType
|
|
transformConstr = applyDepthSM doStructured
|
|
where
|
|
-- For arrays, this takes a constructor expression:
|
|
-- VAL type name IS [i = rep | expr]:
|
|
-- ...
|
|
-- and produces this:
|
|
-- type name:
|
|
-- PROCTHEN
|
|
-- INT indexvar:
|
|
-- SEQ
|
|
-- indexvar := 0
|
|
-- SEQ i = rep
|
|
-- SEQ
|
|
-- name[indexvar] := expr
|
|
-- indexvar := indexvar + 1
|
|
-- ...
|
|
--
|
|
-- For lists, it takes the similar expression and produces:
|
|
-- type name:
|
|
-- PROCTHEN
|
|
-- SEQ i = rep
|
|
-- name += [expr]
|
|
doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
|
|
doStructured (A.Spec m (A.Specification m' n (A.IsExpr _ _ _ expr@(A.ExprConstr m'' (A.RepConstr _ t rep exp)))) scope)
|
|
= do case t of
|
|
A.Array {} ->
|
|
do indexVarSpec@(A.Specification _ indexName _) <- makeNonceVariable "array_constr_index" m'' A.Int A.VariableName A.Original
|
|
let indexVar = A.Variable m'' indexName
|
|
|
|
return $ declDest $ A.ProcThen m''
|
|
(A.Seq m'' $ A.Spec m'' indexVarSpec $
|
|
A.Several m'' [assignIndex0 indexVar,
|
|
A.Rep m'' rep $ A.Only m'' $ A.Seq m'' $
|
|
A.Several m''
|
|
[ assignItem indexVar
|
|
, incrementIndex indexVar ]
|
|
])
|
|
scope
|
|
A.List {} ->
|
|
return $ declDest $ A.ProcThen m''
|
|
(A.Seq m'' $ A.Rep m'' rep $ appendItem)
|
|
scope
|
|
_ -> diePC m $ formatCode "Unsupported type for array constructor: %" t
|
|
where
|
|
declDest :: Data a => A.Structured a -> A.Structured a
|
|
declDest = A.Spec m (A.Specification m' n (A.Declaration m' t))
|
|
|
|
assignIndex0 :: A.Variable -> A.Structured A.Process
|
|
assignIndex0 indexVar = A.Only m'' $ A.Assign m'' [indexVar] $
|
|
A.ExpressionList m'' [A.Literal m'' A.Int $ A.IntLiteral m'' "0"]
|
|
|
|
incrementIndex :: A.Variable -> A.Structured A.Process
|
|
incrementIndex indexVar = A.Only m'' $ A.Assign m'' [indexVar] $
|
|
A.ExpressionList m'' [addOne $ A.ExprVariable m'' indexVar]
|
|
|
|
assignItem :: A.Variable -> A.Structured A.Process
|
|
assignItem indexVar = A.Only m'' $ A.Assign m'' [A.SubscriptedVariable m''
|
|
(A.Subscript m'' A.NoCheck $ A.ExprVariable m'' indexVar) $
|
|
A.Variable m'' n] $ A.ExpressionList m'' [exp]
|
|
|
|
appendItem :: A.Structured A.Process
|
|
appendItem = A.Only m'' $ A.Assign m'' [A.Variable m'' n] $
|
|
A.ExpressionList m'' [A.Dyadic m'' A.Concat
|
|
(A.ExprVariable m'' $ A.Variable m'' n)
|
|
(A.Literal m'' t $ A.ListLiteral m'' [exp])]
|
|
|
|
doStructured s = return s
|
|
|
|
-- | Find things that need to be moved up to their enclosing Structured, and do
|
|
-- so.
|
|
pullUp :: Bool -> PassType
|
|
pullUp pullUpArraysInsideRecords = recurse
|
|
where
|
|
ops :: Ops
|
|
ops = baseOp
|
|
`extOpS` doStructured
|
|
`extOp` doProcess
|
|
`extOp` doSpecification
|
|
`extOp` doLiteralRepr
|
|
`extOp` doExpression
|
|
`extOp` doVariable
|
|
`extOp` doExpressionList
|
|
recurse :: Recurse
|
|
recurse = makeRecurse ops
|
|
descend :: Descend
|
|
descend = makeDescend ops
|
|
|
|
-- | When we encounter a Structured, create a new pulled items state,
|
|
-- recurse over it, then apply whatever pulled items we found to it.
|
|
doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
|
|
doStructured s
|
|
= do pushPullContext
|
|
-- Recurse over the body, then apply the pulled items to it
|
|
s' <- descend s >>= applyPulled
|
|
-- ... and restore the original pulled items
|
|
popPullContext
|
|
return s'
|
|
|
|
-- | As with doStructured: when we find a process, create a new pulled items
|
|
-- context, and if we find any items apply them to it.
|
|
doProcess :: A.Process -> PassM A.Process
|
|
doProcess p
|
|
= do pushPullContext
|
|
p' <- descend p
|
|
pulled <- havePulled
|
|
p'' <- if pulled
|
|
then liftM (A.Seq emptyMeta) $ applyPulled (A.Only emptyMeta p')
|
|
else return p'
|
|
popPullContext
|
|
return p''
|
|
|
|
-- | Filter what can be pulled in Specifications.
|
|
doSpecification :: A.Specification -> PassM A.Specification
|
|
-- Iss might be SubscriptedVars -- which is fine; the backend can deal with that.
|
|
doSpecification (A.Specification m n (A.Is m' am t v))
|
|
= do v' <- descend v -- note descend rather than pullUp
|
|
return $ A.Specification m n (A.Is m' am t v')
|
|
-- IsExprs might be SubscriptedExprs, and if so we have to convert them.
|
|
doSpecification (A.Specification m n (A.IsExpr m' am t e))
|
|
= do e' <- doExpression' e -- note doExpression' rather than recurse
|
|
return $ A.Specification m n (A.IsExpr m' am t e')
|
|
-- Convert RetypesExpr into Retypes of a variable.
|
|
doSpecification (A.Specification m n (A.RetypesExpr m' am toT e))
|
|
= do e' <- doExpression e
|
|
fromT <- astTypeOf e'
|
|
spec@(A.Specification _ n' _) <- makeNonceIsExpr "retypes_expr" m' fromT e'
|
|
addPulled $ (m', Left spec)
|
|
return $ A.Specification m n (A.Retypes m' am toT (A.Variable m' n'))
|
|
doSpecification s = descend s
|
|
|
|
-- | Filter what can be pulled in LiteralReprs.
|
|
doLiteralRepr :: A.LiteralRepr -> PassM A.LiteralRepr
|
|
-- FIXME: We could do away with ArrayElem and have a rule like the below
|
|
-- for nested array literals.
|
|
-- Don't pull up array expressions that are fields of record literals.
|
|
doLiteralRepr (A.RecordLiteral m es)
|
|
= do es' <- mapM (if pullUpArraysInsideRecords then doExpression else doExpression') es -- note doExpression' rather than recurse
|
|
return $ A.RecordLiteral m es'
|
|
doLiteralRepr lr = descend lr
|
|
|
|
-- | Pull array expressions that aren't already non-subscripted variables.
|
|
-- Also pull lists that are literals or constructed
|
|
doExpression :: A.Expression -> PassM A.Expression
|
|
doExpression e
|
|
-- This part handles recursing into the expression first:
|
|
= do e' <- doExpression' e
|
|
t <- astTypeOf e'
|
|
case t of
|
|
A.Array _ _ ->
|
|
case e' of
|
|
A.ExprVariable _ (A.Variable _ _) -> return e'
|
|
A.ExprVariable _ (A.DirectedVariable _ _ _) -> return e'
|
|
--TODO work out whether to pull up DerefVariable
|
|
_ -> pull t e'
|
|
A.List _ ->
|
|
case e' of
|
|
A.ExprConstr {} -> pull t e'
|
|
A.Literal {} -> pull t e'
|
|
_ -> return e'
|
|
_ -> return e'
|
|
where
|
|
pull :: A.Type -> A.Expression -> PassM A.Expression
|
|
pull t e
|
|
= do let m = findMeta e
|
|
spec@(A.Specification _ n _) <- makeNonceIsExpr "array_expr" m t e
|
|
addPulled $ (m, Left spec)
|
|
return $ A.ExprVariable m (A.Variable m n)
|
|
|
|
-- | Pull any variable subscript that results in an array.
|
|
doVariable :: A.Variable -> PassM A.Variable
|
|
doVariable v@(A.SubscriptedVariable m _ _)
|
|
= do v' <- descend v
|
|
t <- astTypeOf v'
|
|
case t of
|
|
A.Array _ _ ->
|
|
do origAM <- abbrevModeOfVariable v'
|
|
let am = makeAbbrevAM origAM
|
|
spec@(A.Specification _ n _) <- makeNonceIs "array_slice" m t am v'
|
|
addPulled $ (m, Left spec)
|
|
return $ A.Variable m n
|
|
_ -> return v'
|
|
doVariable v = descend v
|
|
|
|
-- | Convert a FUNCTION call into some variables and a PROC call.
|
|
convertFuncCall :: Meta -> A.Name -> [A.Expression] -> PassM [A.Variable]
|
|
convertFuncCall m n es
|
|
= do es' <- recurse es
|
|
ets <- sequence [astTypeOf e | e <- es']
|
|
|
|
ps <- get
|
|
rts <- Map.lookup (A.nameName n) (csFunctionReturns ps)
|
|
specs <- sequence [makeNonceVariable "return_actual" m t A.VariableName A.Original | t <- rts]
|
|
sequence_ [addPulled $ (m, Left spec) | spec <- specs]
|
|
|
|
let names = [n | A.Specification _ n _ <- specs]
|
|
let vars = [A.Variable m n | n <- names]
|
|
let call = A.ProcCall m n (map A.ActualExpression es' ++ map A.ActualVariable vars)
|
|
addPulled $ (m, Right call)
|
|
|
|
return vars
|
|
|
|
doExpression' :: A.Expression -> PassM A.Expression
|
|
-- Convert single-valued function calls.
|
|
doExpression' (A.FunctionCall m n es)
|
|
= do [v] <- convertFuncCall m n es
|
|
return $ A.ExprVariable m v
|
|
-- Convert SubscriptedExprs into SubscriptedVariables.
|
|
doExpression' (A.SubscriptedExpr m s e)
|
|
= do e' <- recurse e
|
|
s' <- recurse s
|
|
t <- astTypeOf e'
|
|
spec@(A.Specification _ n _) <- makeNonceIsExpr "subscripted_expr" m t e'
|
|
addPulled $ (m, Left spec)
|
|
return $ A.ExprVariable m (A.SubscriptedVariable m s' (A.Variable m n))
|
|
doExpression' e = descend e
|
|
|
|
doExpressionList :: A.ExpressionList -> PassM A.ExpressionList
|
|
-- Convert multi-valued function calls.
|
|
doExpressionList (A.FunctionCallList m n es)
|
|
= do vs <- convertFuncCall m n es
|
|
return $ A.ExpressionList m [A.ExprVariable m v | v <- vs]
|
|
doExpressionList el = descend el
|
|
|