8f767ff0d4
This makes sure that we catch all leftover instances of using SYB to do generic operations that we should be using Polyplate for instead. Most modules should only import Data, and possibly Typeable.
223 lines
10 KiB
Haskell
223 lines
10 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 processes.
|
|
module SimplifyProcs (simplifyProcs, fixLowReplicators) where
|
|
|
|
import Control.Monad.State
|
|
import Data.Generics (Data)
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import EvalConstants
|
|
import EvalLiterals
|
|
import Metadata
|
|
import Pass
|
|
import qualified Properties as Prop
|
|
import Traversal
|
|
import Types
|
|
import Utils
|
|
|
|
simplifyProcs :: [Pass A.AST]
|
|
simplifyProcs =
|
|
[ parsToProcs
|
|
, removeParAssign
|
|
, flattenAssign
|
|
]
|
|
|
|
-- | Wrap the subprocesses of PARs in no-arg PROCs.
|
|
parsToProcs :: PassOn A.Process
|
|
parsToProcs = pass "Wrap PAR subprocesses in PROCs"
|
|
[Prop.parUsageChecked]
|
|
[Prop.parsWrapped]
|
|
(applyBottomUpM doProcess)
|
|
where
|
|
doProcess :: A.Process -> PassM A.Process
|
|
doProcess (A.Par m pm s)
|
|
= do s' <- doStructured s
|
|
return $ A.Par m pm s'
|
|
doProcess p = return p
|
|
|
|
-- FIXME This should be generic and in Pass.
|
|
doStructured :: A.Structured A.Process -> PassM (A.Structured A.Process)
|
|
doStructured = transformOnly wrapProcess
|
|
where
|
|
wrapProcess m p
|
|
= do s@(A.Specification _ n _) <- makeNonceProc m p
|
|
modify (\cs -> cs { csParProcs = Set.insert n (csParProcs cs) })
|
|
return $ A.Spec m s (A.Only m (A.ProcCall m n []))
|
|
|
|
-- | Turn parallel assignment into multiple single assignments through temporaries.
|
|
removeParAssign :: PassOn A.Process
|
|
removeParAssign = pass "Remove parallel assignment"
|
|
[Prop.parUsageChecked, Prop.functionsRemoved, Prop.functionCallsRemoved]
|
|
[Prop.assignParRemoved]
|
|
(applyBottomUpM doProcess)
|
|
where
|
|
doProcess :: A.Process -> PassM A.Process
|
|
doProcess (A.Assign m vs@(_:_:_) (A.ExpressionList _ es))
|
|
= do ts <- mapM astTypeOf vs
|
|
specs <- sequence [makeNonceVariable "assign_temp" m t A.Original | t <- ts]
|
|
let temps = [A.Variable m n | A.Specification _ n _ <- specs]
|
|
let first = [A.Assign m [v] (A.ExpressionList m [e]) | (v, e) <- zip temps es]
|
|
let second = [A.Assign m [v] (A.ExpressionList m [A.ExprVariable m v']) | (v, v') <- zip vs temps]
|
|
return $ A.Seq m $ foldl (\s spec -> A.Spec m spec s) (A.Several m (map (A.Only m) (first ++ second))) specs
|
|
doProcess p = return p
|
|
|
|
-- | Turn assignment of arrays and records into multiple assignments.
|
|
flattenAssign :: PassOnOps (ExtOpMSP BaseOp `ExtOpMP` A.Process)
|
|
flattenAssign = pass "Flatten assignment"
|
|
(Prop.agg_typesDone ++ [Prop.assignParRemoved])
|
|
[Prop.assignFlattened]
|
|
(makeRecurseM ops)
|
|
where
|
|
ops = baseOp `extOpMS` (ops, makeBottomUpM ops doStructured)
|
|
`extOpM` makeBottomUpM ops doProcess
|
|
|
|
doProcess :: A.Process -> PassM A.Process
|
|
doProcess (A.Assign m [v] (A.ExpressionList m' [e]))
|
|
= do t <- astTypeOf v
|
|
assign m t v m' e
|
|
doProcess p = return p
|
|
|
|
doStructured :: Data a => A.Structured a -> PassM (A.Structured a)
|
|
doStructured (A.Spec m (A.Specification m' n t@(A.RecordType _ _ fs)) s)
|
|
= do procSpec <- recordCopyProc n m fs
|
|
return $ A.Spec m (A.Specification m' n t) (procSpec s)
|
|
doStructured s = return s
|
|
|
|
assign :: Meta -> A.Type -> A.Variable -> Meta -> A.Expression -> PassM A.Process
|
|
assign m t@(A.Array _ _) v m' e = complexAssign m t v m' e
|
|
assign m t@(A.Record _) v m' e = complexAssign m t v m' e
|
|
assign m _ v m' e = return $ A.Assign m [v] (A.ExpressionList m' [e])
|
|
|
|
makeCopyProcName :: A.Name -> PassM A.Name
|
|
makeCopyProcName n = do file <- getCompState >>* csCurrentFile
|
|
let m = Meta (Just file) 0 0
|
|
return $ n {A.nameName = "copy_" ++ mungeMeta m ++ A.nameName n}
|
|
|
|
complexAssign :: Meta -> A.Type -> A.Variable -> Meta -> A.Expression -> PassM A.Process
|
|
complexAssign m t v m' e
|
|
= do -- Abbreviate the source and destination, to avoid doing the
|
|
-- subscript each time.
|
|
destAM <- liftM makeAbbrevAM $ abbrevModeOfVariable v
|
|
dest@(A.Specification _ destN _) <-
|
|
makeNonceIs "assign_dest" m t destAM v
|
|
let destV = A.Variable m destN
|
|
src@(A.Specification _ srcN _) <-
|
|
makeNonceIsExpr "assign_src" m' t e
|
|
let srcV = A.Variable m' srcN
|
|
|
|
body <- case t of
|
|
A.Array (d:_) _ ->
|
|
-- Array assignments become a loop with an assignment
|
|
-- inside.
|
|
do counter <- makeNonceCounter "i" m
|
|
let zero = A.Literal m A.Int $ A.IntLiteral m "0"
|
|
limit = case d of
|
|
A.UnknownDimension -> A.ExprVariable m $ specificDimSize 0 srcV
|
|
A.Dimension e -> e
|
|
rep = A.For m zero limit (makeConstant m 1)
|
|
itemT <- trivialSubscriptType m t
|
|
-- Don't need to check bounds, as we'll always be within bounds
|
|
let sub = A.Subscript m A.NoCheck (A.ExprVariable m
|
|
(A.Variable m counter))
|
|
inner <- assign m itemT
|
|
(A.SubscriptedVariable m sub destV) m'
|
|
(A.ExprVariable m'
|
|
(A.SubscriptedVariable m' sub srcV))
|
|
return $ A.Spec m (A.Specification m counter (A.Rep m rep)) $ A.Only m inner
|
|
A.Record n -> makeCopyProcName n >>= \n' ->
|
|
return $ A.Only m $ A.ProcCall m n'
|
|
[A.ActualVariable destV, A.ActualVariable srcV]
|
|
|
|
return $ A.Seq m $ A.Spec m src $ A.Spec m dest body
|
|
|
|
-- TODO could make this a separate pass if we wanted (to be run first)
|
|
recordCopyProc :: Data a => A.Name -> Meta -> [(A.Name, A.Type)] -> PassM (A.Structured a -> A.Structured a)
|
|
recordCopyProc n m fs
|
|
-- Record assignments become a sequence of
|
|
-- assignments, one for each field.
|
|
= do let t = A.Record n
|
|
(A.Specification _ nonceLHS _) <- makeNonceVariable "record_copy_arg" m t A.Abbrev
|
|
let destV = A.Variable m nonceLHS
|
|
(A.Specification _ nonceRHS _) <- makeNonceVariable "record_copy_arg" m t A.ValAbbrev
|
|
let srcV = A.Variable m nonceRHS
|
|
assigns <-
|
|
sequence [do let sub = A.SubscriptField m fName
|
|
assign m fType
|
|
(A.SubscriptedVariable m sub destV) m
|
|
(A.ExprVariable m
|
|
(A.SubscriptedVariable m sub srcV))
|
|
| (fName, fType) <- fs]
|
|
n' <- makeCopyProcName n
|
|
let code = A.Seq m $ A.Several m $ map (A.Only m) assigns
|
|
proc = A.Proc m (A.InlineSpec, A.PlainRec)
|
|
[A.Formal A.Abbrev t nonceLHS, A.Formal A.ValAbbrev t nonceRHS]
|
|
(Just code)
|
|
defineName n' $ A.NameDef {
|
|
A.ndMeta = m,
|
|
A.ndName = A.nameName n',
|
|
A.ndOrigName = A.nameName n',
|
|
A.ndSpecType = proc,
|
|
A.ndAbbrevMode = A.Original,
|
|
A.ndNameSource = A.NameNonce,
|
|
A.ndPlacement = A.Unplaced
|
|
}
|
|
|
|
|
|
return (A.Spec m (A.Specification m n' proc))
|
|
|
|
-- | Removes replicators with a replicator count of zero,
|
|
-- and transforms replicators with a replicator count of one.
|
|
--
|
|
-- We don't currently transform replicators in array constructors,
|
|
-- just replicators in SEQ, PAR, ALT, IF.
|
|
--
|
|
-- This pass is primarily to make sure that PAR replicators with 0 or 1 counts
|
|
-- pass the usage checking, but it doesn't hurt to remove any redundant code (or
|
|
-- simplify code) in the other replicators.
|
|
fixLowReplicators :: PassOn A.Process
|
|
fixLowReplicators = pass "Fix low-count (0, 1) replicators" [] []
|
|
(applyBottomUpM doProcess)
|
|
where
|
|
doProcess :: Transform A.Process
|
|
doProcess (A.Seq m s) = doStructured s >>* A.Seq m
|
|
doProcess (A.Par m p s) = doStructured s >>* A.Par m p
|
|
doProcess (A.If m s) = doStructured s >>* A.If m
|
|
doProcess (A.Alt m p s) = doStructured s >>* A.Alt m p
|
|
doProcess p = return p
|
|
|
|
doStructured :: Data a => Transform (A.Structured a)
|
|
doStructured s@(A.Only {}) = return s
|
|
doStructured (A.Several m ss) = mapM doStructured ss >>* A.Several m
|
|
doStructured (A.ProcThen m p s) = doStructured s >>* A.ProcThen m p
|
|
doStructured (A.Spec m sp@(A.Specification m' n (A.Rep m''
|
|
(A.For m''' begin end _))) s)
|
|
| isConstant end
|
|
= do endVal <- evalIntExpression end
|
|
case endVal of
|
|
0 -> return $ A.Several m []
|
|
1 -> doStructured s >>*
|
|
A.Spec m (A.Specification m' n
|
|
(A.Is m'' A.ValAbbrev A.Int $ A.ActualExpression begin))
|
|
_ -> doStructured s >>* A.Spec m sp
|
|
doStructured (A.Spec m sp s) = doStructured s >>* A.Spec m sp
|
|
|