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.
249 lines
9.9 KiB
Haskell
249 lines
9.9 KiB
Haskell
{-
|
|
Tock: a compiler for parallel languages
|
|
Copyright (C) 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/>.
|
|
-}
|
|
|
|
-- | The occam-specific frontend passes.
|
|
module OccamPasses (occamPasses, foldConstants, checkConstants) where
|
|
|
|
import Control.Monad.State
|
|
import Data.Generics (Data)
|
|
import Data.List
|
|
import qualified Data.Sequence as Seq
|
|
import qualified Data.Foldable as F
|
|
import System.IO
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Errors
|
|
import EvalConstants
|
|
import EvalLiterals
|
|
import GenerateC -- For nameString
|
|
import Metadata
|
|
import OccamTypes
|
|
import Pass
|
|
import qualified Properties as Prop
|
|
import ShowCode
|
|
import Traversal
|
|
import Types
|
|
import Utils
|
|
|
|
-- | Occam-specific frontend passes.
|
|
occamPasses :: [Pass A.AST]
|
|
occamPasses =
|
|
[ occamOnlyPass "Dummy occam pass" [] (Prop.agg_namesDone ++ [Prop.mainTagged]) return
|
|
, addDirections
|
|
, inferTypes
|
|
, foldConstants
|
|
, fixConstructorTypes
|
|
, checkConstants
|
|
, resolveAmbiguities
|
|
, checkTypes
|
|
, writeIncFile
|
|
, pushUpDirections
|
|
]
|
|
|
|
writeIncFile :: Pass A.AST
|
|
writeIncFile = occamOnlyPass "Write .inc file" [] []
|
|
(passOnlyOnAST "writeIncFile" (\t ->
|
|
do out <- getCompState >>* csOutputIncFile
|
|
case out of
|
|
Just fn -> do f <- liftIO $ openFile fn WriteMode
|
|
contents <- emitProcsAsExternal t >>* (unlines . F.toList)
|
|
liftIO $ hPutStr f contents
|
|
liftIO $ hClose f
|
|
Nothing -> return ()
|
|
return t
|
|
))
|
|
where
|
|
emitProcsAsExternal :: A.AST -> PassM (Seq.Seq String)
|
|
emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Proc _ _ fs (Just _))) scope)
|
|
= do origN <- lookupName n >>* A.ndOrigName
|
|
thisProc <- sequence (
|
|
[return $ "#PRAGMA TOCKEXTERNAL \"PROC " ++ origN ++ "("
|
|
] ++ intersperse (return ",") (map showCode fs) ++
|
|
[return $ ") = " ++ nameString n ++ "\""
|
|
]) >>* concat
|
|
modify $ \cs -> cs { csOriginalTopLevelProcs =
|
|
A.nameName n : csOriginalTopLevelProcs cs }
|
|
emitProcsAsExternal scope >>* (thisProc Seq.<|)
|
|
emitProcsAsExternal (A.Spec _ (A.Specification _ n (A.Function _ _ ts fs (Just _))) scope)
|
|
= do origN <- lookupName n >>* A.ndOrigName
|
|
thisProc <- sequence (
|
|
[return $ "#PRAGMA TOCKEXTERNAL \""
|
|
] ++ intersperse (return ",") (map showCode ts) ++
|
|
[return $ " FUNCTION " ++ showFuncName origN ++ "("
|
|
] ++ intersperse (return ",") (map showCode fs) ++
|
|
[return $ ") = " ++ nameString n ++ "\""
|
|
]) >>* concat
|
|
modify $ \cs -> cs { csOriginalTopLevelProcs =
|
|
A.nameName n : csOriginalTopLevelProcs cs }
|
|
emitProcsAsExternal scope >>* (thisProc Seq.<|)
|
|
emitProcsAsExternal (A.Spec _ (A.Specification _ n _) scope)
|
|
= emitProcsAsExternal scope
|
|
emitProcsAsExternal (A.ProcThen _ _ scope) = emitProcsAsExternal scope
|
|
emitProcsAsExternal (A.Only {}) = return Seq.empty
|
|
emitProcsAsExternal (A.Several _ ss)
|
|
= foldl (liftM2 (Seq.><)) (return Seq.empty) (map emitProcsAsExternal ss)
|
|
|
|
showFuncName :: String -> String
|
|
showFuncName s | isOperator s = "\"" ++ doubleStars s ++ "\""
|
|
| otherwise = s
|
|
where
|
|
doubleStars cs = concat [if c == '*' then "**" else [c] | c <- cs]
|
|
|
|
-- | Fixed the types of array constructors according to the replicator count
|
|
fixConstructorTypes :: PassOn A.Expression
|
|
fixConstructorTypes = occamOnlyPass "Fix the types of array constructors"
|
|
[Prop.constantsFolded]
|
|
[Prop.arrayConstructorTypesDone]
|
|
(applyBottomUpM doExpression)
|
|
where
|
|
doExpression :: A.Expression -> PassM A.Expression
|
|
doExpression (A.Literal m prevT lit@(A.ArrayListLiteral _ expr))
|
|
= do dims <- getDims prevT
|
|
t' <- doExpr [] dims expr
|
|
return $ A.Literal m t' lit
|
|
where
|
|
getDims :: A.Type -> PassM [A.Dimension]
|
|
getDims (A.Array ds _) = return ds
|
|
getDims t@(A.UserDataType {}) = resolveUserType m t >>= getDims
|
|
getDims t = dieP m $ "Cannot deduce dimensions of array constructor: " ++ show t
|
|
|
|
innerType :: A.Type -> PassM A.Type
|
|
innerType (A.Array _ t) = return t
|
|
innerType t@(A.UserDataType {}) = resolveUserType m t >>= innerType
|
|
innerType t = dieP m $ "Cannot deduce dimensions of array constructor: " ++ show t
|
|
|
|
doExpr :: [A.Dimension] -> [A.Dimension] -> A.Structured A.Expression -> PassM A.Type
|
|
doExpr prev (d:_) (A.Several m []) = innerType prevT >>* A.Array (prev ++ [d])
|
|
doExpr prev (d:dims) (A.Several m ss@(s:_))
|
|
= doExpr (prev ++ [d]) dims s
|
|
doExpr prev _ (A.Only _ e)
|
|
= astTypeOf e >>* addDimensions prev
|
|
doExpr prev dims (A.ProcThen _ _ e) = doExpr prev dims e
|
|
doExpr prev (_:dims) (A.Spec _ (A.Specification _ _ (A.Rep _ rep)) body)
|
|
= doExpr (prev ++ [count]) (dims) body
|
|
where
|
|
count = A.Dimension $ countReplicator rep
|
|
doExpr _ dims s = diePC (findMeta s) $ formatCode
|
|
("fixConstructorTypes found unexpected: %, " ++ show s) dims
|
|
|
|
doExpression (A.AllocMobile m _ e@(Just (A.Literal _ t (A.ArrayListLiteral {}))))
|
|
= return $ A.AllocMobile m (A.Mobile t) e
|
|
doExpression e = return e
|
|
|
|
-- | Handle ambiguities in the occam syntax that the parser can't resolve.
|
|
resolveAmbiguities :: PassOn A.ExpressionList
|
|
resolveAmbiguities = occamOnlyPass "Resolve ambiguities"
|
|
[Prop.inferredTypesRecorded]
|
|
[Prop.ambiguitiesResolved]
|
|
(applyBottomUpM doExpressionList)
|
|
where
|
|
doExpressionList :: Transform A.ExpressionList
|
|
-- A single function call inside an ExpressionList is actually a
|
|
-- FunctionCallList, since it can have multiple results.
|
|
doExpressionList (A.ExpressionList _ [A.FunctionCall m n es])
|
|
= return $ A.FunctionCallList m n es
|
|
doExpressionList (A.ExpressionList _ [A.IntrinsicFunctionCall m n es])
|
|
= return $ A.IntrinsicFunctionCallList m n es
|
|
doExpressionList e = return e
|
|
|
|
-- | Fold constant expressions.
|
|
foldConstants :: PassOn2 A.Expression A.Specification
|
|
foldConstants = occamOnlyPass "Fold constants"
|
|
[Prop.inferredTypesRecorded]
|
|
[Prop.constantsFolded]
|
|
(applyBottomUpM2 doExpression doSpecification)
|
|
where
|
|
-- Try to fold all expressions we encounter. Since we've recursed into the
|
|
-- expression first, this'll also fold subexpressions of non-constant
|
|
-- expressions.
|
|
doExpression :: A.Expression -> PassM A.Expression
|
|
doExpression e
|
|
= do (e', _, _) <- constantFold e
|
|
return e'
|
|
|
|
-- After we're done folding a specification, update its definition.
|
|
-- (Even if it isn't an expression itself, it might have others inside it,
|
|
-- so we just update them all.)
|
|
doSpecification :: A.Specification -> PassM A.Specification
|
|
doSpecification spec@(A.Specification m n (A.RetypesExpr _ _ t _))
|
|
= do e <- getConstantName n
|
|
case e of
|
|
Just e' ->
|
|
let newSpec = A.Is m A.ValAbbrev t (A.ActualExpression e') in
|
|
do modifyName n $ \nd -> nd { A.ndSpecType = newSpec }
|
|
return $ A.Specification m n newSpec
|
|
Nothing -> return spec
|
|
doSpecification s@(A.Specification _ n st)
|
|
= do modifyName n (\nd -> nd { A.ndSpecType = st })
|
|
return s
|
|
|
|
-- | Check that things that must be constant are.
|
|
checkConstants :: PassOn2 A.Type A.Option
|
|
checkConstants = occamOnlyPass "Check mandatory constants"
|
|
[Prop.constantsFolded, Prop.arrayConstructorTypesDone]
|
|
[Prop.constantsChecked]
|
|
recurse
|
|
where
|
|
ops = baseOp `extOpM` doType `extOpM` doOption
|
|
|
|
descend :: DescendM PassM (BaseOp `ExtOpMP` A.Type `ExtOpMP` A.Option)
|
|
descend = makeDescendM ops
|
|
recurse :: RecurseM PassM (BaseOp `ExtOpMP` A.Type `ExtOpMP` A.Option)
|
|
recurse = makeRecurseM ops
|
|
|
|
doType :: A.Type -> PassM A.Type
|
|
-- Avoid checking that mobile dimensions are constant:
|
|
doType t@(A.Mobile {}) = return t
|
|
doType (A.Array ds t) = liftM2 A.Array (mapM doDimension ds) (recurse t)
|
|
doType t = descend t
|
|
|
|
-- Check array dimensions are constant.
|
|
doDimension :: A.Dimension -> PassM A.Dimension
|
|
doDimension d@(A.Dimension e)
|
|
= do when (not $ isConstant e) $
|
|
diePC (findMeta e) $ formatCode "Array dimension must be constant: %" e
|
|
return d
|
|
doDimension d = return d
|
|
|
|
-- Check case options are constant.
|
|
doOption :: A.Option -> PassM A.Option
|
|
doOption o@(A.Option _ es _)
|
|
= do sequence_ [when (not $ isConstant e) $
|
|
diePC (findMeta e) $ formatCode "Case option must be constant: %" e
|
|
| e <- es]
|
|
return o
|
|
doOption o = return o
|
|
|
|
-- | Turns things like cs[0]? into cs?[0], which helps later on in the usage checking
|
|
-- (as we can consider cs? a different array than cs!).
|
|
pushUpDirections :: PassOn A.Variable
|
|
pushUpDirections = occamOnlyPass "Push up direction specifiers on arrays"
|
|
[] []
|
|
(applyBottomUpM doVariable)
|
|
where
|
|
doVariable :: Transform A.Variable
|
|
doVariable origV@(A.DirectedVariable m dir v)
|
|
= do t <- astTypeOf v
|
|
case (t, v) of
|
|
(A.Array {}, _) -> return origV
|
|
(_, A.SubscriptedVariable m sub v') ->
|
|
return $ A.SubscriptedVariable m sub $ A.DirectedVariable m dir v'
|
|
_ -> return origV
|
|
doVariable v = return v
|