12b3c4cd89
Also known as communication semantics, I think. The pass adds an extra channel parameter per mobile (perhaps in future this could be a single extra channel?) that is used to send back the mobile value, and hacked the backend so that the communications to receive these mobiles are done in the right place (after the processes have been run, but before waiting on the barrier for them to complete). cgtest83 now compiles, runs and passes without a segfault.
295 lines
12 KiB
Haskell
295 lines
12 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/>.
|
|
-}
|
|
|
|
-- | The function dictionary and various types and helper functions for backends based around C
|
|
module GenerateCBased where
|
|
|
|
import Control.Monad.Reader
|
|
import Control.Monad.State
|
|
import Control.Monad.Writer hiding (tell)
|
|
import Data.Generics
|
|
import Data.List
|
|
import System.IO
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Errors
|
|
import Metadata
|
|
import Pass
|
|
import qualified Properties as Prop
|
|
|
|
cCppCommonPreReq :: [Property]
|
|
cCppCommonPreReq =
|
|
[Prop.afterRemoved
|
|
,Prop.arrayLiteralsExpanded
|
|
,Prop.assignFlattened
|
|
,Prop.assignParRemoved
|
|
,Prop.freeNamesToArgs
|
|
,Prop.functionCallsRemoved
|
|
,Prop.functionsRemoved
|
|
,Prop.inputCaseRemoved
|
|
,Prop.mainTagged
|
|
,Prop.nestedPulled
|
|
,Prop.outExpressionRemoved
|
|
,Prop.parsWrapped
|
|
,Prop.parUsageChecked
|
|
,Prop.subscriptsPulledUp
|
|
,Prop.typesResolvedInAST
|
|
,Prop.typesResolvedInState
|
|
]
|
|
|
|
|
|
--{{{ monad definition
|
|
type CGen' = StateT (Either [String] Handle) PassM
|
|
type CGen = ReaderT GenOps CGen'
|
|
|
|
instance Die CGen where
|
|
dieReport err = lift $ lift $ dieReport err
|
|
|
|
instance CSMR CGen' where
|
|
getCompState = lift getCompState
|
|
|
|
instance CSMR CGen where
|
|
getCompState = lift getCompState
|
|
|
|
tell :: [String] -> CGen ()
|
|
tell x = do st <- get
|
|
case st of
|
|
Left prev -> put $ Left (prev ++ x)
|
|
Right h -> liftIO $ mapM_ (hPutStr h) x
|
|
|
|
csmLift :: PassM a -> CGen a
|
|
csmLift = lift . lift
|
|
--}}}
|
|
|
|
-- | A function that applies a subscript to a variable.
|
|
type SubscripterFunction = A.Variable -> A.Variable
|
|
|
|
--{{{ generator ops
|
|
-- | Operations for turning various things into C.
|
|
-- These are in a structure so that we can reuse operations in other
|
|
-- backends without breaking the mutual recursion.
|
|
data GenOps = GenOps {
|
|
-- | Generates code when a variable goes out of scope (e.g. deallocating memory).
|
|
declareFree :: Meta -> A.Type -> A.Variable -> Maybe (CGen ()),
|
|
-- | Generates code when a variable comes into scope (e.g. allocating memory, initialising variables).
|
|
declareInit :: Meta -> A.Type -> A.Variable -> Maybe (CGen ()),
|
|
-- | Generates an individual parameter to a function\/proc.
|
|
genActual :: A.Formal -> A.Actual -> CGen (),
|
|
-- | Generates the list of actual parameters to a function\/proc.
|
|
genActuals :: [A.Formal] -> [A.Actual] -> CGen (),
|
|
genAllocMobile :: Meta -> A.Type -> Maybe A.Expression -> CGen(),
|
|
genAlt :: Bool -> A.Structured A.Alternative -> CGen (),
|
|
-- | Generates the given array element expressions as a flattened (one-dimensional) list of literals
|
|
genArrayLiteralElems :: A.Structured A.Expression -> CGen (),
|
|
-- | Writes out the actual data storage array name.
|
|
genArrayStoreName :: A.Name -> CGen(),
|
|
-- | Generates an array subscript for the given variable (with error checking according to the first variable), using the given expression list as subscripts
|
|
genArraySubscript :: A.SubscriptCheck -> A.Variable -> [(Meta, CGen ())] -> CGen (),
|
|
genAssert :: Meta -> A.Expression -> CGen (),
|
|
-- | Generates an assignment statement with a single destination and single source.
|
|
genAssign :: Meta -> [A.Variable] -> A.ExpressionList -> CGen (),
|
|
-- | Generates the number of bytes in a fixed size type, fails if a free dimension is present and is not allowed.
|
|
-- The Either parameter is either an array variable (to use the _sizes array of) or a boolean specifying
|
|
-- wheter or not one free dimension is allowed (True <=> allowed).
|
|
genBytesIn :: Meta -> A.Type -> Either Bool A.Variable -> CGen (),
|
|
-- | Generates a case statement over the given expression with the structured as the body.
|
|
genCase :: Meta -> A.Expression -> A.Structured A.Option -> CGen (),
|
|
genCheckedConversion :: Meta -> A.Type -> A.Type -> CGen () -> CGen (),
|
|
genClearMobile :: Meta -> A.Variable -> CGen (),
|
|
genCloneMobile :: Meta -> A.Expression -> CGen (),
|
|
genConversion :: Meta -> A.ConversionMode -> A.Type -> A.Expression -> CGen (),
|
|
genConversionSymbol :: A.Type -> A.Type -> A.ConversionMode -> CGen (),
|
|
getCType :: Meta -> A.Type -> A.AbbrevMode -> CGen CType,
|
|
genDecl :: A.AbbrevMode -> A.Type -> A.Name -> CGen (),
|
|
-- | Generates a declaration of a variable of the specified type and name.
|
|
-- The Bool indicates whether the declaration is inside a record (True) or not (False).
|
|
genDeclaration :: A.Type -> A.Name -> Bool -> CGen (),
|
|
genDirectedVariable :: Meta -> A.Type -> CGen () -> A.Direction -> CGen (),
|
|
genDyadic :: Meta -> A.DyadicOp -> A.Expression -> A.Expression -> CGen (),
|
|
genExpression :: A.Expression -> CGen (),
|
|
genFlatArraySize :: [A.Dimension] -> CGen (),
|
|
genForwardDeclaration :: A.Specification -> CGen(),
|
|
genFuncDyadic :: Meta -> String -> A.Expression -> A.Expression -> CGen (),
|
|
genFuncMonadic :: Meta -> String -> A.Expression -> CGen (),
|
|
-- | Gets the current time into the given variable
|
|
genGetTime :: A.Variable -> CGen (),
|
|
-- | Generates an IF statement (which can have replicators, specifications and such things inside it).
|
|
genIf :: Meta -> A.Structured A.Choice -> CGen (),
|
|
genInput :: A.Variable -> A.InputMode -> CGen (),
|
|
genInputItem :: A.Variable -> A.InputItem -> CGen (),
|
|
genIntrinsicFunction :: Meta -> String -> [A.Expression] -> CGen (),
|
|
genIntrinsicProc :: Meta -> String -> [A.Actual] -> CGen (),
|
|
genListAssign :: A.Variable -> A.Expression -> CGen (),
|
|
genListConcat :: A.Expression -> A.Expression -> CGen (),
|
|
genListLiteral :: A.Structured A.Expression -> A.Type -> CGen (),
|
|
genListSize :: A.Variable -> CGen (),
|
|
genLiteral :: A.LiteralRepr -> A.Type -> CGen (),
|
|
genLiteralRepr :: A.LiteralRepr -> A.Type -> CGen (),
|
|
genMissing :: String -> CGen (),
|
|
genMissingC :: CGen String -> CGen (),
|
|
genMonadic :: Meta -> A.MonadicOp -> A.Expression -> CGen (),
|
|
-- | Generates an output statement.
|
|
genOutput :: A.Variable -> [(A.Type, A.OutputItem)] -> CGen (),
|
|
-- | Generates an output statement for a tagged protocol.
|
|
genOutputCase :: A.Variable -> A.Name -> [A.OutputItem] -> CGen (),
|
|
-- | Generates an output for an individual item.
|
|
genOutputItem :: A.Type -> A.Variable -> A.OutputItem -> CGen (),
|
|
-- | Generates a loop that maps over every element in a (potentially multi-dimensional) array
|
|
genOverArray :: Meta -> A.Variable -> (SubscripterFunction -> Maybe (CGen ())) -> CGen (),
|
|
genPar :: A.ParMode -> A.Structured A.Process -> CGen (),
|
|
genPoison :: Meta -> A.Variable -> CGen (),
|
|
genProcCall :: A.Name -> [A.Actual] -> CGen (),
|
|
genProcess :: A.Process -> CGen (),
|
|
genRecordTypeSpec :: A.Name -> A.RecordAttr -> [(A.Name, A.Type)] -> CGen (),
|
|
genReplicatorStart :: A.Name -> A.Replicator -> CGen (),
|
|
genReplicatorEnd :: A.Replicator -> CGen (),
|
|
-- | Generates the three bits of a for loop (e.g. @int i = 0; i < 10; i++@ for the given replicator)
|
|
genReplicatorLoop :: A.Name -> A.Replicator -> CGen (),
|
|
genReschedule :: CGen(),
|
|
genRetypeSizes :: Meta -> A.Type -> A.Name -> A.Type -> A.Variable -> CGen (),
|
|
genSeq :: A.Structured A.Process -> CGen (),
|
|
genSimpleDyadic :: String -> A.Expression -> A.Expression -> CGen (),
|
|
genSimpleMonadic :: String -> A.Expression -> CGen (),
|
|
genSizeSuffix :: String -> CGen (),
|
|
genSpec :: forall b. A.Specification -> CGen b -> CGen b,
|
|
genSpecMode :: A.SpecMode -> CGen (),
|
|
-- | Generates a STOP process that uses the given Meta tag and message as its printed message.
|
|
genStop :: Meta -> String -> CGen (),
|
|
genStructured :: forall a b. Data a => A.Structured a -> (Meta -> a -> CGen b) -> CGen [b],
|
|
genTimerRead :: A.Variable -> A.Variable -> CGen (),
|
|
genTimerWait :: A.Expression -> CGen (),
|
|
genTopLevel :: A.AST -> CGen (),
|
|
genTypeSymbol :: String -> A.Type -> CGen (),
|
|
genUnfoldedExpression :: A.Expression -> CGen (),
|
|
genUnfoldedVariable :: Meta -> A.Variable -> CGen (),
|
|
-- | Generates a variable, with indexing checks if needed
|
|
genVariable :: A.Variable -> A.AbbrevMode -> CGen (),
|
|
-- Like genVariable, but modifies the desired CType
|
|
genVariable' :: A.Variable -> A.AbbrevMode -> (CType -> CType) -> CGen (),
|
|
-- | Generates a variable, with no indexing checks anywhere
|
|
genVariableUnchecked :: A.Variable -> A.AbbrevMode -> CGen (),
|
|
-- | Generates a while loop with the given condition and body.
|
|
genWhile :: A.Expression -> A.Process -> CGen (),
|
|
getScalarType :: A.Type -> Maybe String,
|
|
introduceSpec :: A.Specification -> CGen (),
|
|
removeSpec :: A.Specification -> CGen ()
|
|
}
|
|
|
|
-- | Call an operation in GenOps.
|
|
class CGenCall a where
|
|
call :: (GenOps -> a) -> a
|
|
|
|
instance CGenCall (CGen z) where
|
|
call f = do ops <- ask
|
|
f ops
|
|
|
|
instance CGenCall (a -> CGen z) where
|
|
-- call :: (a -> CGen b) -> a -> CGen b
|
|
call f x0 = do ops <- ask
|
|
f ops x0
|
|
|
|
instance CGenCall (a -> b -> CGen z) where
|
|
call f x0 x1
|
|
= do ops <- ask
|
|
f ops x0 x1
|
|
|
|
instance CGenCall (a -> b -> c -> CGen z) where
|
|
call f x0 x1 x2
|
|
= do ops <- ask
|
|
f ops x0 x1 x2
|
|
|
|
instance CGenCall (a -> b -> c -> d -> CGen z) where
|
|
call f x0 x1 x2 x3
|
|
= do ops <- ask
|
|
f ops x0 x1 x2 x3
|
|
|
|
instance CGenCall (a -> b -> c -> d -> e -> CGen z) where
|
|
call f x0 x1 x2 x3 x4
|
|
= do ops <- ask
|
|
f ops x0 x1 x2 x3 x4
|
|
|
|
fget :: (GenOps -> a) -> CGen a
|
|
fget = asks
|
|
|
|
generate :: GenOps -> Handle -> A.AST -> PassM ()
|
|
generate ops h ast = evalStateT (runReaderT (call genTopLevel ast) ops) (Right h)
|
|
|
|
genComma :: CGen ()
|
|
genComma = tell [","]
|
|
|
|
seqComma :: [CGen ()] -> CGen ()
|
|
seqComma ps = sequence_ $ intersperse genComma ps
|
|
|
|
-- C or C++ type, really.
|
|
data CType
|
|
= Plain String
|
|
| Pointer CType
|
|
| Const CType
|
|
| Template String [CType]
|
|
-- | Subscript CType
|
|
deriving (Eq)
|
|
|
|
instance Show CType where
|
|
show (Plain s) = s
|
|
show (Pointer t) = show t ++ "*"
|
|
show (Const t) = show t ++ " const "
|
|
show (Template wr cts) = wr ++ "<" ++ concat (intersperse "," $ map show cts) ++ ">/**/"
|
|
-- show (Subscript t) = "(" ++ show t ++ "[n])"
|
|
|
|
stripPointers :: CType -> CType
|
|
stripPointers (Pointer t) = t
|
|
stripPointers (Const (Pointer t)) = t
|
|
stripPointers t = t
|
|
|
|
-- Like Eq, but ignores const
|
|
closeEnough :: CType -> CType -> Bool
|
|
closeEnough (Const t) t' = closeEnough t t'
|
|
closeEnough t (Const t') = closeEnough t t'
|
|
closeEnough (Pointer t) (Pointer t') = closeEnough t t'
|
|
closeEnough (Plain s) (Plain s') = s == s'
|
|
closeEnough (Template wr cts) (Template wr' cts')
|
|
= wr == wr' && length cts == length cts' && and (zipWith closeEnough cts cts')
|
|
closeEnough _ _ = False
|
|
|
|
-- Given some code to generate, and its type, and the type that you actually want,
|
|
-- adds the required decorators. Only pass it simplified types!
|
|
dressUp :: Meta -> (CGen (), CType) -> CType -> CGen ()
|
|
dressUp _ (gen, t) t' | t `closeEnough` t' = gen
|
|
--Every line after here is not close enough, so we know equality fails:
|
|
dressUp m (gen, Pointer t) (Pointer t')
|
|
= dressUp m (gen, t) t'
|
|
dressUp m (gen, Const t) t'
|
|
= dressUp m (gen, t) t'
|
|
dressUp m (gen, t) (Const t')
|
|
= dressUp m (gen, t) t'
|
|
dressUp m (gen, t@(Plain {})) (Pointer t')
|
|
= dressUp m (tell ["(&("] >> gen >> tell ["))"], t) t'
|
|
dressUp m (gen, Pointer t) t'@(Plain {})
|
|
= dressUp m (tell ["(*("] >> gen >> tell ["))"], t) t'
|
|
dressUp m (gen, t) t'
|
|
= dieP m $ "Types cannot be brought together: " ++ show t ++ " and " ++ show t'
|
|
|
|
genType :: A.Type -> CGen ()
|
|
genType t = do ct <- call getCType emptyMeta t A.Original
|
|
tell [show ct]
|
|
|
|
genCType :: Meta -> A.Type -> A.AbbrevMode -> CGen ()
|
|
genCType m t am = do ct <- call getCType m t am
|
|
tell [show ct]
|