From ca207f72916479f6d8ec79af6960a1f9c1fc15ea Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sat, 21 Mar 2009 18:43:32 +0000 Subject: [PATCH] Quickly implemented the first version of a revamp of the genVariable code in the C backend 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. --- backends/GenerateC.hs | 69 +++++++++++++++++++++++++++----------- backends/GenerateCBased.hs | 39 ++++++++++++++++++++- 2 files changed, 87 insertions(+), 21 deletions(-) diff --git a/backends/GenerateC.hs b/backends/GenerateC.hs index 5cf34f8..a3092b0 100644 --- a/backends/GenerateC.hs +++ b/backends/GenerateC.hs @@ -38,6 +38,7 @@ module GenerateC , withIf ) where +import Control.Arrow import Data.Char import Data.Generics import Data.List @@ -147,9 +148,9 @@ cgenOps = GenOps { genTypeSymbol = cgenTypeSymbol, genUnfoldedExpression = cgenUnfoldedExpression, genUnfoldedVariable = cgenUnfoldedVariable, - genVariable = cgenVariable, - genVariableAM = cgenVariableAM, - genVariableUnchecked = cgenVariableUnchecked, + genVariable = \v -> cgenVariableWithAM True v (Just A.Original), + genVariableAM = \v am -> cgenVariableWithAM True v (Just am), + genVariableUnchecked = \v -> cgenVariableWithAM False v (Just A.Original), genWhile = cgenWhile, getScalarType = cgetScalarType, introduceSpec = cintroduceSpec, @@ -718,6 +719,7 @@ CHAN OF INT c: Channel c; Channel *c; I suspect there's probably a nicer way of doing this, but as a translation of the above table this isn't too horrible... -} +{- -- | Generate C code for a variable. cgenVariable :: A.Variable -> CGen () cgenVariable = cgenVariable' True @@ -725,12 +727,26 @@ cgenVariable = cgenVariable' True -- | Generate C code for a variable without doing any range checks. cgenVariableUnchecked :: A.Variable -> CGen () cgenVariableUnchecked = cgenVariable' False +-} -cgenVariable' :: Bool -> A.Variable -> CGen () -cgenVariable' checkValid v - = do (cg, n) <- inner 0 v Nothing +cgenVariableWithAM :: Bool -> A.Variable -> Maybe A.AbbrevMode -> CGen () +cgenVariableWithAM checkValid v mam + = do let iv@(A.Variable m n) = findInnerV v + t <- astTypeOf v + ct <- getVariableCType m (maybe (Right v) (\am -> Left (t, am)) mam) + cti <- getVariableCType m (Right iv) + dressUp m (genName n, cti) ct + +{- = do (cg, n) <- inner 0 v Nothing addPrefix cg n +-} where + findInnerV :: A.Variable -> A.Variable + findInnerV v@(A.Variable {}) = v + findInnerV (A.DerefVariable _ v) = findInnerV v + findInnerV (A.DirectedVariable _ _ v) = findInnerV v + findInnerV (A.SubscriptedVariable _ _ v) = findInnerV v + -- The general plan here is to generate the variable, while also -- putting in the right prefixes (&/*/**/***/etc). -- We use an "indirection level" to record the prefix needed. @@ -740,7 +756,7 @@ cgenVariable' checkValid v -- so that we can add the appropriate prefixes before the array -- name. That is, we make sure we write (&foo[0]), not -- (&foo)[0] - +{- inner :: Int -> A.Variable -> Maybe A.Type -> CGen (CGen (), Int) inner ind (A.Variable _ n) mt = do amN <- abbrevModeOfName n @@ -838,6 +854,32 @@ cgenVariable' checkValid v return (es' ++ [e], v', t) collectSubs v = do t <- astTypeOf v return ([], v, t) +-} +getVariableCType :: Meta -> Either (A.Type, A.AbbrevMode) A.Variable -> CGen CType +getVariableCType m e + = do (t, am) <- either return (seqPair . (astTypeOf &&& abbrevModeOfVariable)) e + sc <- fget getScalarType >>* ($ t) + let isMobile = False + case (t, sc, isMobile, am) of + -- All abbrev modes: + (A.Array _ t, _, False, _) + -> getVariableCType m (Left (t, A.Original)) >>* Pointer + + (A.Record n, _, False, A.Original) -> return $ Plain $ nameString n + -- Abbrev and ValAbbrev: + (A.Record n, _, False, _) -> return $ Pointer $ Plain $ nameString n + + -- All abbrev modes for channels: + (A.Chan {}, _, False, _) -> return $ Pointer $ Plain "Channel" + (A.ChanEnd {}, _, False, _) -> return $ Pointer $ Plain "Channel" + + -- Scalar types: + (_, Just pl, False, A.Original) -> return $ Plain pl + (_, Just pl, False, A.Abbrev) -> return $ Pointer $ Plain pl + (_, Just pl, False, A.ValAbbrev) -> return $ Plain pl + + -- Must have missed one: + _ -> diePC m $ formatCode "Cannot work out the C type for: %" t -- | Return whether a type is one that is declared as a structure, but -- abbreviated as a pointer. @@ -1184,19 +1226,6 @@ cgenReplicatorLoop _ _ = cgenMissing "ForEach loops not yet supported in the C b --{{{ abbreviations -cgenVariableAM :: A.Variable -> A.AbbrevMode -> CGen () -cgenVariableAM v am - = do when (am == A.Abbrev) $ - do t <- astTypeOf v - case (indirectedType t, t) of - (True, _) -> return () - (False, A.Array {}) -> return () - (False, A.Chan {}) -> return () - (False, A.ChanEnd {}) -> return () --- (False, A.Mobile {}) -> return () - _ -> tell ["&"] - call genVariable v - -- | Generate the size part of a RETYPES\/RESHAPES abbrevation of a variable. cgenRetypeSizes :: Meta -> A.Type -> A.Name -> A.Type -> A.Variable -> CGen () cgenRetypeSizes _ (A.Chan {}) _ (A.Chan {}) _ = return () diff --git a/backends/GenerateCBased.hs b/backends/GenerateCBased.hs index 4af98d7..656d90f 100644 --- a/backends/GenerateCBased.hs +++ b/backends/GenerateCBased.hs @@ -22,7 +22,7 @@ module GenerateCBased where import Control.Monad.Error import Control.Monad.Reader import Control.Monad.State -import Control.Monad.Writer +import Control.Monad.Writer hiding (tell) import Data.Generics import System.IO @@ -230,3 +230,40 @@ 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'