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.
326 lines
13 KiB
Haskell
326 lines
13 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 (Data)
|
|
import Data.List
|
|
import System.IO
|
|
|
|
import qualified AST as A
|
|
import CompState
|
|
import Errors
|
|
import Metadata
|
|
import Pass
|
|
import qualified Properties as Prop
|
|
import Utils
|
|
|
|
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
|
|
]
|
|
|
|
type CGenOutput = Either [String] Handle
|
|
data CGenOutputs = CGenOutputs
|
|
{ cgenBody :: CGenOutput
|
|
, cgenHeader :: CGenOutput
|
|
}
|
|
|
|
--{{{ monad definition
|
|
type CGen' = StateT CGenOutputs 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
|
|
|
|
-- Do not nest calls to this function!
|
|
tellToHeader :: CGen a -> CGen a
|
|
tellToHeader act
|
|
= do st <- get
|
|
put $ st { cgenBody = cgenHeader st }
|
|
x <- act
|
|
st' <- get
|
|
put $ st' { cgenBody = cgenBody st, cgenHeader = cgenBody st' }
|
|
return x
|
|
|
|
tell :: [String] -> CGen ()
|
|
tell x = do st <- get
|
|
case cgenBody st of
|
|
Left prev -> put $ st { cgenBody = 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
|
|
|
|
data Level = TopLevel | NotTopLevel
|
|
|
|
--{{{ 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 :: Level -> 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 :: Level -> A.Type -> A.Name -> Bool -> CGen (),
|
|
genDirectedVariable :: Meta -> A.Type -> CGen () -> A.Direction -> CGen (),
|
|
genExpression :: A.Expression -> CGen (),
|
|
genFlatArraySize :: [A.Dimension] -> CGen (),
|
|
genForwardDeclaration :: A.Specification -> CGen(),
|
|
-- | Only used for built-in operators at the moment:
|
|
genFunctionCall :: Meta -> A.Name -> [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 (),
|
|
-- | 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 (),
|
|
genSpec :: forall b. Level -> 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 => Level -> A.Structured a -> (Meta -> a -> CGen b) -> CGen [b],
|
|
genTimerRead :: A.Variable -> A.Variable -> CGen (),
|
|
genTimerWait :: A.Expression -> CGen (),
|
|
genTopLevel :: String -> A.AST -> CGen (),
|
|
genTypeSymbol :: String -> A.Type -> CGen (),
|
|
genUnfoldedExpression :: A.Expression -> CGen (),
|
|
genUnfoldedVariable :: Meta -> A.Variable -> 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 :: Level -> A.Specification -> CGen (),
|
|
removeSpec :: A.Specification -> CGen ()
|
|
}
|
|
|
|
-- | Generates a variable, with indexing checks if needed
|
|
genVariable :: GenOps -> A.Variable -> A.AbbrevMode -> CGen ()
|
|
genVariable ops v am = genVariable' ops v am id
|
|
|
|
-- | 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
|
|
|
|
-- Handles are body, header, occam-inc
|
|
generate :: GenOps -> (Handle, Handle) -> String -> A.AST -> PassM ()
|
|
generate ops (hb, hh) hname ast
|
|
= evalStateT (runReaderT (call genTopLevel hname ast) ops)
|
|
(CGenOutputs (Right hb) (Right hh))
|
|
|
|
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 [Either CType A.Expression]
|
|
-- | 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 (either show show) cts) ++ ">/**/"
|
|
-- show (Subscript t) = "(" ++ show t ++ "[n])"
|
|
|
|
replacePlainType :: String -> String -> CType -> CType
|
|
replacePlainType old new (Const ct) = Const $ replacePlainType old new ct
|
|
replacePlainType old new (Pointer ct) = Pointer $ replacePlainType old new ct
|
|
replacePlainType old new (Template t xs)
|
|
= Template t $ [transformEither (replacePlainType old new) id x | x <- xs]
|
|
replacePlainType old new (Plain t)
|
|
| old == t = Plain new
|
|
| otherwise = Plain t
|
|
|
|
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')
|
|
where
|
|
closeEnough' (Left ct) (Left ct') = closeEnough ct ct'
|
|
closeEnough' (Right _) (Right _) = True -- can't really check
|
|
closeEnough' _ _ = False
|
|
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) (Pointer t')
|
|
= dressUp m (tell ["&"] >> gen, t) t'
|
|
dressUp m (gen, Pointer t) t'
|
|
= dressUp m (tell ["*"] >> gen, 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]
|