ca207f7291
Surprisingly, the generated code seems to be compiled by GCC without warnings. Array subscripts are currently unimplemented (a star, i.e. equivalent of subscript 0) is used wherever there should be a subscript. The new mechanism is based on working out the C type of the original variable/abbrev-mode, the C type of the desired variable/abbrev-mode, and works out how many *s or &s to insert to coerce it to the right type.
270 lines
11 KiB
Haskell
270 lines
11 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.Error
|
|
import Control.Monad.Reader
|
|
import Control.Monad.State
|
|
import Control.Monad.Writer hiding (tell)
|
|
import Data.Generics
|
|
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 (),
|
|
genDecl :: A.AbbrevMode -> A.Type -> A.Name -> CGen (),
|
|
genDeclType :: A.AbbrevMode -> A.Type -> 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 -> Bool -> [(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 :: A.Specification -> CGen () -> CGen (),
|
|
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. Data a => A.Structured a -> (Meta -> a -> CGen ()) -> CGen (),
|
|
genTimerRead :: A.Variable -> A.Variable -> CGen (),
|
|
genTimerWait :: A.Expression -> CGen (),
|
|
genTopLevel :: A.AST -> CGen (),
|
|
-- | Generates the type as it might be used in a cast expression
|
|
genType :: A.Type -> 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 -> CGen (),
|
|
genVariableAM :: A.Variable -> A.AbbrevMode -> CGen (),
|
|
-- | Generates a variable, with no indexing checks anywhere
|
|
genVariableUnchecked :: A.Variable -> 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)
|
|
|
|
data CType
|
|
= Plain String
|
|
| Pointer CType
|
|
| Const CType
|
|
-- | Subscript CType
|
|
deriving (Eq)
|
|
|
|
instance Show CType where
|
|
show (Plain s) = s
|
|
show (Pointer t) = show t ++ "*"
|
|
show (Const t) = "(const " ++ show t ++ ")"
|
|
-- show (Subscript t) = "(" ++ show t ++ "[n])"
|
|
|
|
-- Like Eq, but ignores const
|
|
closeEnough :: CType -> CType -> Bool
|
|
closeEnough (Const t) t' = closeEnough t t'
|
|
closeEnough t (Const t') = closeEnough t t'
|
|
closeEnough t t' = t == t'
|
|
|
|
-- 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, t@(Plain {})) t'@(Plain {})
|
|
= dieP m $ "Types cannot be brought together: " ++ show t ++ " and " ++ show t'
|
|
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'
|