suzanne.soy/tock-mirror
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Started simplifying some of the C backend in light of the new changes, and made a few fixes

Browse Source 
The first few cgtests (at least) now pass with the new system in the C backend.
This commit is contained in:
Neil Brown 2009-03-21 22:59:25 +00:00
parent 63d6c5258d
commit defca6e34d
2 changed files with 119 additions and 142 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

227
backends/GenerateC.hs
View File

@ -21,7 +21,7 @@ with this program. If not, see <http://www.gnu.org/licenses/>.
module GenerateC module GenerateC
( cgenOps ( cgenOps
, cgenReplicatorLoop , cgenReplicatorLoop
, cgenType , cgetCType
, cintroduceSpec , cintroduceSpec
, cPreReq , cPreReq
, cremoveSpec , cremoveSpec
@ -38,7 +38,6 @@ module GenerateC
, withIf , withIf
) where ) where
import Control.Arrow
import Data.Char import Data.Char
import Data.Generics import Data.Generics
import Data.List import Data.List
@ -95,8 +94,8 @@ cgenOps = GenOps {
genCloneMobile = cgenCloneMobile, genCloneMobile = cgenCloneMobile,
genConversion = cgenConversion, genConversion = cgenConversion,
genConversionSymbol = cgenConversionSymbol, genConversionSymbol = cgenConversionSymbol,
getCType = cgetCType,
genDecl = cgenDecl, genDecl = cgenDecl,
genDeclType = cgenDeclType,
genDeclaration = cgenDeclaration, genDeclaration = cgenDeclaration,
genDirectedVariable = cgenDirectedVariable, genDirectedVariable = cgenDirectedVariable,
genDyadic = cgenDyadic, genDyadic = cgenDyadic,
@ -144,13 +143,11 @@ cgenOps = GenOps {
genTimerRead = cgenTimerRead, genTimerRead = cgenTimerRead,
genTimerWait = cgenTimerWait, genTimerWait = cgenTimerWait,
genTopLevel = cgenTopLevel, genTopLevel = cgenTopLevel,
genType = cgenType,
genTypeSymbol = cgenTypeSymbol, genTypeSymbol = cgenTypeSymbol,
genUnfoldedExpression = cgenUnfoldedExpression, genUnfoldedExpression = cgenUnfoldedExpression,
genUnfoldedVariable = cgenUnfoldedVariable, genUnfoldedVariable = cgenUnfoldedVariable,
genVariable = \v -> cgenVariableWithAM True v (Just A.Original), genVariable = cgenVariableWithAM True,
genVariableAM = \v am -> cgenVariableWithAM True v (Just am), genVariableUnchecked = cgenVariableWithAM False,
genVariableUnchecked = \v -> cgenVariableWithAM False v (Just A.Original),
genWhile = cgenWhile, genWhile = cgenWhile,
getScalarType = cgetScalarType, getScalarType = cgetScalarType,
introduceSpec = cintroduceSpec, introduceSpec = cintroduceSpec,
@ -272,17 +269,17 @@ cgenOverArray m var func
case func arg of case func arg of
Just p -> Just p ->
do sequence_ [do tell ["for(int "] do sequence_ [do tell ["for(int "]
call genVariable i call genVariable i A.Original
tell ["=0;"] tell ["=0;"]
call genVariable i call genVariable i A.Original
tell ["<"] tell ["<"]
case d of case d of
A.UnknownDimension -> A.UnknownDimension ->
do call genVariable var do call genVariable var A.Original
call genSizeSuffix (show v) call genSizeSuffix (show v)
A.Dimension n -> call genExpression n A.Dimension n -> call genExpression n
tell [";"] tell [";"]
call genVariable i call genVariable i A.Original
tell ["++){"] tell ["++){"]
| (v :: Integer, i, d) <- zip3 [0..] indices ds] | (v :: Integer, i, d) <- zip3 [0..] indices ds]
p p
@ -332,37 +329,6 @@ cgetScalarType (A.Timer A.OccamTimer) = Just "Time"
cgetScalarType A.Time = Just "Time" cgetScalarType A.Time = Just "Time"
cgetScalarType _ = Nothing cgetScalarType _ = Nothing
-- | Generate the C type corresponding to a variable being declared.
-- It must be possible to use this in arrays.
cgenType :: A.Type -> CGen ()
cgenType (A.Array _ t)
= do call genType t
case t of
A.Chan _ _ -> tell ["*"]
-- Channel ends don't need an extra indirection; in C++ they are not
-- pointers, and in C they are already pointers
_ -> return ()
tell ["*"]
cgenType (A.Record n) = genName n
cgenType (A.Mobile t@(A.Array {})) = tell["mt_array_t*"]
cgenType (A.Mobile t) = call genType t >> tell ["*"]
-- UserProtocol -- not used
-- Channels are of type "Channel", but channel-ends are of type "Channel*"
cgenType (A.Chan _ t) = tell ["Channel"]
cgenType (A.ChanEnd _ _ t) = tell ["Channel*"]
-- Counted -- not used
-- Any -- not used
--cgenType (A.Port t) =
cgenType (A.List {}) = tell ["GQueue*"]
cgenType t
= do f <- fget getScalarType
case f t of
Just s -> tell [s]
Nothing -> call genMissingC $ formatCode "genType %" t
indexOfFreeDimensions :: [A.Dimension] -> [Int] indexOfFreeDimensions :: [A.Dimension] -> [Int]
indexOfFreeDimensions = (mapMaybe indexOfFreeDimensions') . (zip [0..]) indexOfFreeDimensions = (mapMaybe indexOfFreeDimensions') . (zip [0..])
where where
@ -397,11 +363,11 @@ cgenBytesIn m t v
-- allow retyping between channels and other things. -- allow retyping between channels and other things.
genBytesIn' t@(A.Chan {}) genBytesIn' t@(A.Chan {})
= do tell ["sizeof("] = do tell ["sizeof("]
call genType t genType t
tell [")"] tell [")"]
genBytesIn' t@(A.ChanEnd {}) genBytesIn' t@(A.ChanEnd {})
= do tell ["sizeof("] = do tell ["sizeof("]
call genType t genType t
tell [")"] tell [")"]
genBytesIn' (A.Mobile _) genBytesIn' (A.Mobile _)
= tell ["sizeof(void*)"] = tell ["sizeof(void*)"]
@ -423,7 +389,7 @@ cgenBytesIn m t v
genBytesInArrayDim (A.UnknownDimension, i) genBytesInArrayDim (A.UnknownDimension, i)
= case v of = case v of
Right rv -> Right rv ->
do call genVariable rv do call genVariable rv A.Original
call genSizeSuffix (show i) call genSizeSuffix (show i)
tell ["*"] tell ["*"]
_ -> return () _ -> return ()
@ -431,20 +397,9 @@ cgenBytesIn m t v
--}}} --}}}
--{{{ declarations --{{{ declarations
cgenDeclType :: A.AbbrevMode -> A.Type -> CGen ()
cgenDeclType am t
= do when (am == A.ValAbbrev) $ tell ["const "]
call genType t
case t of
A.Array _ _ -> return ()
A.ChanEnd A.DirInput _ _ -> return ()
A.ChanEnd A.DirOutput _ _ -> return ()
A.Record _ -> tell ["*const"]
_ -> when (am == A.Abbrev) $ tell ["*const"]
cgenDecl :: A.AbbrevMode -> A.Type -> A.Name -> CGen () cgenDecl :: A.AbbrevMode -> A.Type -> A.Name -> CGen ()
cgenDecl am t n cgenDecl am t n
= do call genDeclType am t = do genCType (A.nameMeta n) t am
tell [" "] tell [" "]
genName n genName n
--}}} --}}}
@ -453,7 +408,7 @@ cgenDecl am t n
cgenCheckedConversion :: Meta -> A.Type -> A.Type -> CGen () -> CGen () cgenCheckedConversion :: Meta -> A.Type -> A.Type -> CGen () -> CGen ()
cgenCheckedConversion m fromT toT exp cgenCheckedConversion m fromT toT exp
= do tell ["(("] = do tell ["(("]
call genType toT genType toT
tell [") "] tell [") "]
if isSafeConversion fromT toT if isSafeConversion fromT toT
then exp then exp
@ -509,9 +464,9 @@ cgenConversion m cm toT e
cgenConversionSymbol :: A.Type -> A.Type -> A.ConversionMode -> CGen () cgenConversionSymbol :: A.Type -> A.Type -> A.ConversionMode -> CGen ()
cgenConversionSymbol fromT toT cm cgenConversionSymbol fromT toT cm
= do tell ["occam_convert_"] = do tell ["occam_convert_"]
call genType fromT genType fromT
tell ["_"] tell ["_"]
call genType toT genType toT
tell ["_"] tell ["_"]
case cm of case cm of
A.Round -> tell ["round"] A.Round -> tell ["round"]
@ -560,15 +515,15 @@ cgenListLiteral (A.Several _ es) t
cgenListSize :: A.Variable -> CGen () cgenListSize :: A.Variable -> CGen ()
cgenListSize v = do tell ["g_queue_get_length("] cgenListSize v = do tell ["g_queue_get_length("]
call genVariable v call genVariable v A.Original
tell [")"] tell [")"]
cgenListAssign :: A.Variable -> A.Expression -> CGen () cgenListAssign :: A.Variable -> A.Expression -> CGen ()
cgenListAssign v e cgenListAssign v e
= do tell ["tock_free_queue("] = do tell ["tock_free_queue("]
call genVariable v call genVariable v A.Original
tell [");"] tell [");"]
call genVariable v call genVariable v A.Original
tell ["="] tell ["="]
call genExpression e call genExpression e
tell [";"] tell [";"]
@ -631,7 +586,7 @@ cgenUnfoldedVariable m var
-- We can defeat the usage check here because we know it's safe; *we're* -- We can defeat the usage check here because we know it's safe; *we're*
-- generating the subscripts. -- generating the subscripts.
-- FIXME Is that actually true for something like [a[x]]? -- FIXME Is that actually true for something like [a[x]]?
_ -> call genVariableUnchecked var _ -> call genVariableUnchecked var A.Original
where where
unfoldArray :: [A.Dimension] -> A.Variable -> CGen () unfoldArray :: [A.Dimension] -> A.Variable -> CGen ()
unfoldArray [] v = call genUnfoldedVariable m v unfoldArray [] v = call genUnfoldedVariable m v
@ -729,11 +684,11 @@ cgenVariableUnchecked :: A.Variable -> CGen ()
cgenVariableUnchecked = cgenVariable' False cgenVariableUnchecked = cgenVariable' False
-} -}
cgenVariableWithAM :: Bool -> A.Variable -> Maybe A.AbbrevMode -> CGen () cgenVariableWithAM :: Bool -> A.Variable -> A.AbbrevMode -> CGen ()
cgenVariableWithAM checkValid v mam cgenVariableWithAM checkValid v am
= do iv <- inner v = do iv <- inner v
t <- astTypeOf v t <- astTypeOf v
ct <- getVariableCType m (t, fromMaybe A.Original mam) ct <- call getCType m t am
dressUp m iv ct dressUp m iv ct
{- = do (cg, n) <- inner 0 v Nothing {- = do (cg, n) <- inner 0 v Nothing
@ -745,7 +700,7 @@ cgenVariableWithAM checkValid v mam
details :: A.Variable -> CGen CType details :: A.Variable -> CGen CType
details v = do t <- astTypeOf v details v = do t <- astTypeOf v
am <- abbrevModeOfVariable v am <- abbrevModeOfVariable v
getVariableCType m (t, am) call getCType m t am
inner :: A.Variable -> CGen (CGen (), CType) inner :: A.Variable -> CGen (CGen (), CType)
inner v@(A.Variable m n) inner v@(A.Variable m n)
@ -756,8 +711,8 @@ cgenVariableWithAM checkValid v mam
case t of case t of
A.Array _ innerT -> A.Array _ innerT ->
do (cg, ct) <- inner v do (cg, ct) <- inner v
innerCT <- getVariableCType m (t, A.Original) innerCT <- call getCType m t A.Original
let cast = tell ["("] >> call genType innerT >> tell ["*)"] let cast = tell ["("] >> genType innerT >> tell ["*)"]
return (tell ["("] >> cast >> tell ["(("] >> cg >> tell [")->data))"] return (tell ["("] >> cast >> tell ["(("] >> cg >> tell [")->data))"]
, Pointer $ innerCT) , Pointer $ innerCT)
_ -> inner v _ -> inner v
@ -772,14 +727,14 @@ cgenVariableWithAM checkValid v mam
Pointer ct <- details iv Pointer ct <- details iv
let check = if checkValid then subCheck else A.NoCheck let check = if checkValid then subCheck else A.NoCheck
-- Arrays should be pointers to the inner element: -- Arrays should be pointers to the inner element:
return (do cgenVariableWithAM checkValid iv Nothing return (do cgenVariableWithAM checkValid iv A.Original
call genArraySubscript check iv (map (\e -> (findMeta e, call genExpression e)) es) call genArraySubscript check iv (map (\e -> (findMeta e, call genExpression e)) es)
, ct) , ct)
A.SubscriptField _ fieldName A.SubscriptField _ fieldName
-> do ct <- details v -> do ct <- details v
-- For records, we expect it to be a pointer to a record: -- For records, we expect it to be a pointer to a record:
return (do tell ["("] return (do tell ["("]
cgenVariableWithAM checkValid v Nothing cgenVariableWithAM checkValid v A.Original
tell [")."] tell [")."]
genName fieldName genName fieldName
, ct) , ct)
@ -787,7 +742,7 @@ cgenVariableWithAM checkValid v mam
-> do ct <- details v -> do ct <- details v
return (do let check = if checkValid then subCheck else A.NoCheck return (do let check = if checkValid then subCheck else A.NoCheck
tell ["(&"] tell ["(&"]
cgenVariableWithAM checkValid v Nothing cgenVariableWithAM checkValid v A.Original
call genArraySubscript A.NoCheck v [(m', call genArraySubscript A.NoCheck v [(m',
case check of case check of
A.NoCheck -> call genExpression start A.NoCheck -> call genExpression start
@ -847,7 +802,7 @@ cgenVariableWithAM checkValid v mam
case (t, am, mt) of case (t, am, mt) of
(A.Array _ t, _, _) -> (A.Array _ t, _, _) ->
do (cg, n) <- inner ind v Nothing do (cg, n) <- inner ind v Nothing
let cast = tell ["("] >> call genType t >> tell ["*)"] let cast = tell ["("] >> genType t >> tell ["*)"]
return (tell ["("] >> cast >> tell ["(("] >> addPrefix cg n >> tell [")->data))"], 0) return (tell ["("] >> cast >> tell ["(("] >> addPrefix cg n >> tell [")->data))"], 0)
(A.Record {}, A.Original,_) -> inner ind v mt (A.Record {}, A.Original,_) -> inner ind v mt
_ -> inner (ind+1) v mt _ -> inner (ind+1) v mt
@ -916,32 +871,42 @@ unwrapMobileType :: A.Type -> CGen (Bool, A.Type)
unwrapMobileType (A.Mobile t) = return (True, t) unwrapMobileType (A.Mobile t) = return (True, t)
unwrapMobileType t = return (False, t) unwrapMobileType t = return (False, t)
getVariableCType :: Meta -> (A.Type, A.AbbrevMode) -> CGen CType cgetCType :: Meta -> A.Type -> A.AbbrevMode -> CGen CType
getVariableCType m (origT, am) cgetCType m origT am
= do (isMobile, t) <- unwrapMobileType origT = do (isMobile, t) <- unwrapMobileType origT
sc <- fget getScalarType >>* ($ t) sc <- fget getScalarType >>* ($ t)
case (t, sc, isMobile, am) of case (t, sc, isMobile, am) of
-- Channel arrays are a special case, because they are arrays of pointers
-- to channels (so that an abbreviated array of channels, and an array
-- of abbreviations of channels, both look the same)
(A.Array _ (A.Chan {}), _, False, _)
-> return $ Pointer $ Pointer $ Plain "Channel"
(A.Array _ (A.ChanEnd {}), _, False, _)
-> return $ Pointer $ Pointer $ Plain "Channel"
-- All abbrev modes: -- All abbrev modes:
(A.Array _ t, _, False, _) (A.Array _ t, _, False, _)
-> getVariableCType m (t, A.Original) >>* Pointer -> call getCType m t A.Original >>* (Pointer . const)
(A.Array {}, _, True, A.Abbrev) -> return $ Pointer $ Pointer $ Plain "mt_array_t" (A.Array {}, _, True, A.Abbrev) -> return $ Pointer $ Pointer $ Plain "mt_array_t"
(A.Array {}, _, True, _) -> return $ Pointer $ Plain "mt_array_t" (A.Array {}, _, True, _) -> return $ Pointer $ Plain "mt_array_t"
(A.Record n, _, False, A.Original) -> return $ Plain $ nameString n (A.Record n, _, False, A.Original) -> return $ Plain $ nameString n
-- Abbrev and ValAbbrev: -- Abbrev and ValAbbrev:
(A.Record n, _, False, _) -> return $ Pointer $ Plain $ nameString n (A.Record n, _, False, _) -> return $ Pointer $ const $ Plain $ nameString n
-- All abbrev modes for channels: (A.Chan {}, _, False, A.Original) -> return $ Plain "Channel"
(A.Chan {}, _, False, _) -> return $ Pointer $ Plain "Channel" (A.Chan {}, _, False, A.Abbrev) -> return $ Pointer $ Plain "Channel"
(A.ChanEnd {}, _, False, _) -> return $ Pointer $ Plain "Channel" (A.ChanEnd {}, _, False, _) -> return $ Pointer $ Plain "Channel"
-- Scalar types: -- Scalar types:
(_, Just pl, False, A.Original) -> return $ Plain pl (_, Just pl, False, A.Original) -> return $ Plain pl
(_, Just pl, False, A.Abbrev) -> return $ Pointer $ Plain pl (_, Just pl, False, A.Abbrev) -> return $ Pointer $ Plain pl
(_, Just pl, False, A.ValAbbrev) -> return $ Plain pl (_, Just pl, False, A.ValAbbrev) -> return $ Const $ Plain pl
-- Must have missed one: -- Must have missed one:
_ -> diePC m $ formatCode "Cannot work out the C type for: %" t _ -> diePC m $ formatCode "Cannot work out the C type for: %" t
where
const = if am == A.ValAbbrev then Const else id
-- | Return whether a type is one that is declared as a structure, but -- | Return whether a type is one that is declared as a structure, but
-- abbreviated as a pointer. -- abbreviated as a pointer.
@ -967,11 +932,11 @@ cgenArraySubscript check v es
genDynamicDim v i genDynamicDim v i
= do t <- astTypeOf v = do t <- astTypeOf v
case (t, v) of case (t, v) of
(A.Mobile {}, _) -> do call genVariable v (A.Mobile {}, _) -> do call genVariable v A.Original
tell ["->dimensions[", show i, "]"] tell ["->dimensions[", show i, "]"]
(_, A.DerefVariable _ v') -> do call genVariable v' (_, A.DerefVariable _ v') -> do call genVariable v' A.Original
tell ["->dimensions[", show i, "]"] tell ["->dimensions[", show i, "]"]
_ -> call genVariable v >> call genSizeSuffix (show i) _ -> call genVariable v A.Original >> call genSizeSuffix (show i)
-- | Generate the individual offsets that need adding together to find the -- | Generate the individual offsets that need adding together to find the
-- right place in the array. -- right place in the array.
@ -1036,7 +1001,7 @@ cgenExpression (A.SizeVariable m v)
A.Dimension n -> call genExpression n A.Dimension n -> call genExpression n
A.UnknownDimension -> A.UnknownDimension ->
let (n, v') = countSubscripts v let (n, v') = countSubscripts v
in do call genVariable v' in do call genVariable v' A.Original
call genSizeSuffix (show n) call genSizeSuffix (show n)
A.List _ -> A.List _ ->
call genListSize v call genListSize v
@ -1044,18 +1009,18 @@ cgenExpression e@(A.AllSizesVariable m v)
= case v of = case v of
A.SubscriptedVariable {} -> call genMissing $ "genExpression" ++ show e A.SubscriptedVariable {} -> call genMissing $ "genExpression" ++ show e
A.DirectedVariable _ _ v' -> call genExpression $ A.AllSizesVariable m v' A.DirectedVariable _ _ v' -> call genExpression $ A.AllSizesVariable m v'
A.DerefVariable _ v' -> do call genVariable v' A.DerefVariable _ v' -> do call genVariable v' A.Original
tell ["->dimensions"] tell ["->dimensions"]
A.Variable _ n -> do t <- astTypeOf v A.Variable _ n -> do t <- astTypeOf v
case t of case t of
A.Array {} -> do call genVariable v A.Array {} -> do call genVariable v A.Original
tell ["_sizes"] tell ["_sizes"]
A.Mobile (A.Array {}) A.Mobile (A.Array {})
-> do call genVariable v -> do call genVariable v A.Original
tell ["->dimensions"] tell ["->dimensions"]
_ -> call genMissing $ "genExpression" ++ show e _ -> call genMissing $ "genExpression" ++ show e
cgenExpression (A.Conversion m cm t e) = call genConversion m cm t e cgenExpression (A.Conversion m cm t e) = call genConversion m cm t e
cgenExpression (A.ExprVariable m v) = call genVariable v cgenExpression (A.ExprVariable m v) = call genVariable v A.Original
cgenExpression (A.Literal _ t lr) = call genLiteral lr t cgenExpression (A.Literal _ t lr) = call genLiteral lr t
cgenExpression (A.True m) = tell ["true"] cgenExpression (A.True m) = tell ["true"]
cgenExpression (A.False m) = tell ["false"] cgenExpression (A.False m) = tell ["false"]
@ -1174,35 +1139,35 @@ cgenInputItem c (A.InCounted m cv av)
= do call genInputItem c (A.InVariable m cv) = do call genInputItem c (A.InVariable m cv)
t <- astTypeOf av t <- astTypeOf av
tell ["ChanIn(wptr,"] tell ["ChanIn(wptr,"]
call genVariable c call genVariable c A.Abbrev
tell [","] tell [","]
call genVariableAM av A.Abbrev call genVariable av A.Abbrev
tell [","] tell [","]
subT <- trivialSubscriptType m t subT <- trivialSubscriptType m t
call genVariable cv call genVariable cv A.Original
tell ["*"] tell ["*"]
call genBytesIn m subT (Right av) call genBytesIn m subT (Right av)
tell [");"] tell [");"]
cgenInputItem c (A.InVariable m v) cgenInputItem c (A.InVariable m v)
= do t <- astTypeOf v = do t <- astTypeOf v
let rhs = call genVariableAM v A.Abbrev let rhs = call genVariable v A.Abbrev
case t of case t of
A.Int -> A.Int ->
do tell ["ChanInInt(wptr,"] do tell ["ChanInInt(wptr,"]
call genVariable c call genVariable c A.Abbrev
tell [","] tell [","]
rhs rhs
tell [");"] tell [");"]
A.Mobile {} -> A.Mobile {} ->
do call genClearMobile m v -- TODO insert this via a pass do call genClearMobile m v -- TODO insert this via a pass
tell ["MTChanIn(wptr,"] tell ["MTChanIn(wptr,"]
call genVariable c call genVariable c A.Abbrev
tell [",(void*)"] tell [",(void*)"]
rhs rhs
tell [");"] tell [");"]
_ -> _ ->
do tell ["ChanIn(wptr,"] do tell ["ChanIn(wptr,"]
call genVariable c call genVariable c A.Abbrev
tell [","] tell [","]
rhs rhs
tell [","] tell [","]
@ -1217,9 +1182,9 @@ cgenOutputItem _ c (A.OutCounted m ce ae)
case ae of case ae of
A.ExprVariable m v -> A.ExprVariable m v ->
do tell ["ChanOut(wptr,"] do tell ["ChanOut(wptr,"]
call genVariable c call genVariable c A.Abbrev
tell [","] tell [","]
call genVariableAM v A.Abbrev call genVariable v A.Abbrev
tell [","] tell [","]
subT <- trivialSubscriptType m t subT <- trivialSubscriptType m t
call genExpression ce call genExpression ce
@ -1230,27 +1195,27 @@ cgenOutputItem innerT c (A.OutExpression m e)
= case (innerT, e) of = case (innerT, e) of
(A.Int, _) -> (A.Int, _) ->
do tell ["ChanOutInt(wptr,"] do tell ["ChanOutInt(wptr,"]
call genVariable c call genVariable c A.Abbrev
tell [","] tell [","]
call genExpression e call genExpression e
tell [");"] tell [");"]
(A.Mobile {}, A.ExprVariable _ (A.DerefVariable _ v)) -> (A.Mobile {}, A.ExprVariable _ (A.DerefVariable _ v)) ->
do tell ["{void* outtmp = MTClone(*"] do tell ["{void* outtmp = MTClone(*"]
call genVariableAM v A.Abbrev call genVariable v A.Abbrev
tell [");MTChanOut(wptr,"] tell [");MTChanOut(wptr,"]
call genVariable c call genVariable c A.Abbrev
tell [",&outtmp);}"] tell [",&outtmp);}"]
(A.Mobile {}, A.ExprVariable _ v) -> (A.Mobile {}, A.ExprVariable _ v) ->
do tell ["MTChanOut(wptr,"] do tell ["MTChanOut(wptr,"]
call genVariable c call genVariable c A.Abbrev
tell [",(void*)"] tell [",(void*)"]
call genVariableAM v A.Abbrev call genVariable v A.Abbrev
tell [");"] tell [");"]
(_, A.ExprVariable _ v) -> (_, A.ExprVariable _ v) ->
do tell ["ChanOut(wptr,"] do tell ["ChanOut(wptr,"]
call genVariable c call genVariable c A.Abbrev
tell [","] tell [","]
call genVariableAM v A.Abbrev call genVariable v A.Abbrev
tell [","] tell [","]
te <- astTypeOf e te <- astTypeOf e
call genBytesIn m te (Right v) call genBytesIn m te (Right v)
@ -1316,7 +1281,7 @@ cgenRetypeSizes m destT destN srcT srcV
abbrevExpression :: A.AbbrevMode -> A.Type -> A.Expression -> CGen () abbrevExpression :: A.AbbrevMode -> A.Type -> A.Expression -> CGen ()
abbrevExpression am t@(A.Array _ _) e abbrevExpression am t@(A.Array _ _) e
= case e of = case e of
A.ExprVariable _ v -> call genVariableAM v am A.ExprVariable _ v -> call genVariable v am
A.Literal _ t@(A.Array _ _) r -> call genExpression e A.Literal _ t@(A.Array _ _) r -> call genExpression e
_ -> call genMissing "array expression abbreviation" _ -> call genMissing "array expression abbreviation"
abbrevExpression am _ e = call genExpression e abbrevExpression am _ e = call genExpression e
@ -1332,7 +1297,7 @@ cgenSpec spec body
-- | Generate a declaration of a new variable. -- | Generate a declaration of a new variable.
cgenDeclaration :: A.Type -> A.Name -> Bool -> CGen () cgenDeclaration :: A.Type -> A.Name -> Bool -> CGen ()
cgenDeclaration at@(A.Array ds t) n False cgenDeclaration at@(A.Array ds t) n False
= do call genType t = do genType t
tell [" "] tell [" "]
case t of case t of
A.Chan _ _ -> A.Chan _ _ ->
@ -1340,20 +1305,20 @@ cgenDeclaration at@(A.Array ds t) n False
tell ["_storage"] tell ["_storage"]
call genFlatArraySize ds call genFlatArraySize ds
tell [";"] tell [";"]
call genType t genType t
tell ["* "] tell ["* "]
_ -> return () _ -> return ()
call genArrayStoreName n call genArrayStoreName n
call genFlatArraySize ds call genFlatArraySize ds
tell [";"] tell [";"]
cgenDeclaration (A.Array ds t) n True cgenDeclaration (A.Array ds t) n True
= do call genType t = do genType t
tell [" "] tell [" "]
call genArrayStoreName n call genArrayStoreName n
call genFlatArraySize ds call genFlatArraySize ds
tell [";"] tell [";"]
cgenDeclaration t n _ cgenDeclaration t n _
= do call genType t = do genType t
tell [" "] tell [" "]
genName n genName n
tell [";"] tell [";"]
@ -1372,15 +1337,15 @@ cgenFlatArraySize ds
cdeclareInit :: Meta -> A.Type -> A.Variable -> Maybe (CGen ()) cdeclareInit :: Meta -> A.Type -> A.Variable -> Maybe (CGen ())
cdeclareInit _ (A.Chan _ _) var cdeclareInit _ (A.Chan _ _) var
= Just $ do tell ["ChanInit(wptr,"] = Just $ do tell ["ChanInit(wptr,"]
call genVariableUnchecked var call genVariableUnchecked var A.Abbrev
tell [");"] tell [");"]
cdeclareInit m t@(A.Array ds t') var cdeclareInit m t@(A.Array ds t') var
= Just $ do case t' of = Just $ do case t' of
A.Chan _ _ -> A.Chan _ _ ->
do tell ["tock_init_chan_array("] do tell ["tock_init_chan_array("]
call genVariableUnchecked var call genVariableUnchecked var A.Original
tell ["_storage,"] tell ["_storage,"]
call genVariableUnchecked var call genVariableUnchecked var A.Original
tell [","] tell [","]
sequence_ $ intersperse (tell ["*"]) sequence_ $ intersperse (tell ["*"])
[call genExpression n | A.Dimension n <- ds] [call genExpression n | A.Dimension n <- ds]
@ -1428,7 +1393,7 @@ cintroduceSpec (A.Specification m n (A.Declaration _ t))
Just p -> p Just p -> p
Nothing -> return () Nothing -> return ()
cintroduceSpec (A.Specification _ n (A.Is _ am t v)) cintroduceSpec (A.Specification _ n (A.Is _ am t v))
= do let rhs = call genVariableAM v am = do let rhs = call genVariable v am
call genDecl am t n call genDecl am t n
tell ["="] tell ["="]
rhs rhs
@ -1440,7 +1405,7 @@ cintroduceSpec (A.Specification _ n (A.IsExpr _ am t e))
-- For "VAL []T a IS [vs]:", we have to use [] rather than * in the -- For "VAL []T a IS [vs]:", we have to use [] rather than * in the
-- declaration, since you can't say "int *foo = {vs};" in C. -- declaration, since you can't say "int *foo = {vs};" in C.
do tell ["const "] do tell ["const "]
call genType ts genType ts
tell [" "] tell [" "]
genName n genName n
tell ["[] = "] tell ["[] = "]
@ -1451,7 +1416,7 @@ cintroduceSpec (A.Specification _ n (A.IsExpr _ am t e))
-- directly writing a struct literal in C that you can use -> on. -- directly writing a struct literal in C that you can use -> on.
do tmp <- csmLift $ makeNonce "record_literal" do tmp <- csmLift $ makeNonce "record_literal"
tell ["const "] tell ["const "]
call genType t genType t
tell [" ", tmp, " = "] tell [" ", tmp, " = "]
rhs rhs
tell [";\n"] tell [";\n"]
@ -1463,15 +1428,15 @@ cintroduceSpec (A.Specification _ n (A.IsExpr _ am t e))
rhs rhs
tell [";\n"] tell [";\n"]
cintroduceSpec (A.Specification _ n (A.IsChannelArray _ (A.Array _ c) cs)) cintroduceSpec (A.Specification _ n (A.IsChannelArray _ (A.Array _ c) cs))
= do call genType c = do genType c
case c of case c of
A.Chan _ _ -> tell ["*"] A.Chan _ _ -> tell ["* "]
-- Channel ends don't need an extra indirection; in C++ they are not -- Channel ends don't need an extra indirection; in C++ they are not
-- pointers, and in C they are already pointers -- pointers, and in C they are already pointers
_ -> return () _ -> tell [" "]
call genArrayStoreName n call genArrayStoreName n
tell ["[]={"] tell ["[]={"]
seqComma (map (call genVariable) cs) seqComma (map (\v -> call genVariable v A.Abbrev) cs)
tell ["};"] tell ["};"]
cintroduceSpec (A.Specification _ _ (A.DataType _ _)) = return () cintroduceSpec (A.Specification _ _ (A.DataType _ _)) = return ()
cintroduceSpec (A.Specification _ _ (A.RecordType _ _ _)) = return () cintroduceSpec (A.Specification _ _ (A.RecordType _ _ _)) = return ()
@ -1489,7 +1454,7 @@ cintroduceSpec (A.Specification _ n st@(A.Proc _ _ _ _))
= genProcSpec n st False = genProcSpec n st False
cintroduceSpec (A.Specification _ n (A.Retypes m am t v)) cintroduceSpec (A.Specification _ n (A.Retypes m am t v))
= do origT <- astTypeOf v = do origT <- astTypeOf v
let rhs = call genVariableAM v A.Abbrev let rhs = call genVariable v A.Abbrev
call genDecl am t n call genDecl am t n
tell ["="] tell ["="]
-- For scalar types that are VAL abbreviations (e.g. VAL INT64), -- For scalar types that are VAL abbreviations (e.g. VAL INT64),
@ -1503,7 +1468,7 @@ cintroduceSpec (A.Specification _ n (A.Retypes m am t v))
_ -> False _ -> False
when deref $ tell ["*"] when deref $ tell ["*"]
tell ["("] tell ["("]
call genDeclType am t genCType m t am
when deref $ tell ["*"] when deref $ tell ["*"]
tell [")"] tell [")"]
rhs rhs
@ -1570,13 +1535,13 @@ realActuals :: A.Formal -> A.Actual -> [CGen ()]
realActuals _ (A.ActualExpression e) realActuals _ (A.ActualExpression e)
= [call genExpression e] = [call genExpression e]
realActuals (A.Formal am _ _) (A.ActualVariable v) realActuals (A.Formal am _ _) (A.ActualVariable v)
= [call genVariableAM v am] = [call genVariable v am]
-- | Return (type, name) generator pairs for all the real formals corresponding -- | Return (type, name) generator pairs for all the real formals corresponding
-- to a single formal. -- to a single formal.
realFormals :: A.Formal -> [(CGen (), CGen ())] realFormals :: A.Formal -> [(CGen (), CGen ())]
realFormals (A.Formal am t n) realFormals (A.Formal am t n)
= [(call genDeclType am t, genName n)] = [(genCType (A.nameMeta n) t am, genName n)]
-- | Generate a Proc specification, which maps to a C function. -- | Generate a Proc specification, which maps to a C function.
-- This will use ProcGetParam if the Proc is in csParProcs, or the normal C -- This will use ProcGetParam if the Proc is in csParProcs, or the normal C
@ -1687,12 +1652,12 @@ cgenAssign m [v] (A.ExpressionList _ [e])
where where
doAssign :: A.Variable -> A.Expression -> CGen () doAssign :: A.Variable -> A.Expression -> CGen ()
doAssign v e doAssign v e
= do call genVariable v = do call genVariable v A.Original
tell ["="] tell ["="]
call genExpression e call genExpression e
tell [";"] tell [";"]
cgenAssign m (v:vs) (A.IntrinsicFunctionCallList _ n es) cgenAssign m (v:vs) (A.IntrinsicFunctionCallList _ n es)
= do call genVariable v = do call genVariable v A.Original
let (funcName, giveMeta) = case lookup n simpleFloatIntrinsics of let (funcName, giveMeta) = case lookup n simpleFloatIntrinsics of
Just (_,cName) -> (cName, False) Just (_,cName) -> (cName, False)
Nothing -> ("occam_" ++ [if c == '.' then '_' else c | c <- n], True) Nothing -> ("occam_" ++ [if c == '.' then '_' else c | c <- n], True)
@ -1726,7 +1691,7 @@ cgenTimerWait e
cgenGetTime :: A.Variable -> CGen () cgenGetTime :: A.Variable -> CGen ()
cgenGetTime v cgenGetTime v
= do call genVariable v = do call genVariable v A.Original
tell [" = TimerRead(wptr);"] tell [" = TimerRead(wptr);"]
--}}} --}}}
@ -1741,7 +1706,7 @@ cgenOutputCase c tag ois
A.Chan _ (A.UserProtocol n) -> n A.Chan _ (A.UserProtocol n) -> n
A.ChanEnd _ _ (A.UserProtocol n) -> n A.ChanEnd _ _ (A.UserProtocol n) -> n
tell ["ChanOutInt(wptr,"] tell ["ChanOutInt(wptr,"]
call genVariable c call genVariable c A.Original
tell [","] tell [","]
genName tag genName tag
tell ["_"] tell ["_"]
@ -1923,7 +1888,7 @@ cgenAlt isPri s
tell [");\n"] tell [");\n"]
_ -> _ ->
do tell ["AltEnableChannel (wptr,", id, "++,"] do tell ["AltEnableChannel (wptr,", id, "++,"]
call genVariable c call genVariable c A.Original
tell [");\n"] tell [");\n"]
genAltDisable :: String -> A.Structured A.Alternative -> CGen () genAltDisable :: String -> A.Structured A.Alternative -> CGen ()
@ -1943,7 +1908,7 @@ cgenAlt isPri s
tell [");\n"] tell [");\n"]
_ -> _ ->
do tell ["AltDisableChannel (wptr,", id, "++, "] do tell ["AltDisableChannel (wptr,", id, "++, "]
call genVariable c call genVariable c A.Original
tell [");\n"] tell [");\n"]
genAltProcesses :: String -> String -> String -> A.Structured A.Alternative -> CGen () genAltProcesses :: String -> String -> String -> A.Structured A.Alternative -> CGen ()
@ -2037,7 +2002,7 @@ cgenClearMobile _ v
genVar genVar
tell ["=NULL;}"] tell ["=NULL;}"]
where where
genVar = call genVariable v genVar = call genVariable v A.Original
cgenCloneMobile :: Meta -> A.Expression -> CGen () cgenCloneMobile :: Meta -> A.Expression -> CGen ()
cgenCloneMobile _ e cgenCloneMobile _ e

34
backends/GenerateCBased.hs
View File

@ -19,11 +19,11 @@ 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 -- | The function dictionary and various types and helper functions for backends based around C
module GenerateCBased where module GenerateCBased where
import Control.Monad.Error
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.State import Control.Monad.State
import Control.Monad.Writer hiding (tell) import Control.Monad.Writer hiding (tell)
import Data.Generics import Data.Generics
import Data.List
import System.IO import System.IO
import qualified AST as A import qualified AST as A
@ -115,8 +115,8 @@ data GenOps = GenOps {
genCloneMobile :: Meta -> A.Expression -> CGen (), genCloneMobile :: Meta -> A.Expression -> CGen (),
genConversion :: Meta -> A.ConversionMode -> A.Type -> A.Expression -> CGen (), genConversion :: Meta -> A.ConversionMode -> A.Type -> A.Expression -> CGen (),
genConversionSymbol :: A.Type -> A.Type -> A.ConversionMode -> 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 (), 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. -- | 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). -- The Bool indicates whether the declaration is inside a record (True) or not (False).
genDeclaration :: A.Type -> A.Name -> Bool -> CGen (), genDeclaration :: A.Type -> A.Name -> Bool -> CGen (),
@ -175,16 +175,13 @@ data GenOps = GenOps {
genTimerRead :: A.Variable -> A.Variable -> CGen (), genTimerRead :: A.Variable -> A.Variable -> CGen (),
genTimerWait :: A.Expression -> CGen (), genTimerWait :: A.Expression -> CGen (),
genTopLevel :: A.AST -> 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 (), genTypeSymbol :: String -> A.Type -> CGen (),
genUnfoldedExpression :: A.Expression -> CGen (), genUnfoldedExpression :: A.Expression -> CGen (),
genUnfoldedVariable :: Meta -> A.Variable -> CGen (), genUnfoldedVariable :: Meta -> A.Variable -> CGen (),
-- | Generates a variable, with indexing checks if needed -- | Generates a variable, with indexing checks if needed
genVariable :: A.Variable -> CGen (), genVariable :: A.Variable -> A.AbbrevMode -> CGen (),
genVariableAM :: A.Variable -> A.AbbrevMode -> CGen (),
-- | Generates a variable, with no indexing checks anywhere -- | Generates a variable, with no indexing checks anywhere
genVariableUnchecked :: A.Variable -> CGen (), genVariableUnchecked :: A.Variable -> A.AbbrevMode -> CGen (),
-- | Generates a while loop with the given condition and body. -- | Generates a while loop with the given condition and body.
genWhile :: A.Expression -> A.Process -> CGen (), genWhile :: A.Expression -> A.Process -> CGen (),
getScalarType :: A.Type -> Maybe String, getScalarType :: A.Type -> Maybe String,
@ -231,32 +228,37 @@ fget = asks
generate :: GenOps -> Handle -> A.AST -> PassM () generate :: GenOps -> Handle -> A.AST -> PassM ()
generate ops h ast = evalStateT (runReaderT (call genTopLevel ast) ops) (Right h) generate ops h ast = evalStateT (runReaderT (call genTopLevel ast) ops) (Right h)
-- C or C++ type, really.
data CType data CType
= Plain String = Plain String
| Pointer CType | Pointer CType
| Const CType | Const CType
| Template String [CType]
-- | Subscript CType -- | Subscript CType
deriving (Eq) deriving (Eq)
instance Show CType where instance Show CType where
show (Plain s) = s show (Plain s) = s
show (Pointer t) = show t ++ "*" show (Pointer t) = show t ++ "*"
show (Const t) = "(const " ++ show t ++ ")" show (Const t) = show t ++ " const "
show (Template wr cts) = wr ++ "<" ++ concat (intersperse "," $ map show cts) ++ ">/**/"
-- show (Subscript t) = "(" ++ show t ++ "[n])" -- show (Subscript t) = "(" ++ show t ++ "[n])"
-- Like Eq, but ignores const -- Like Eq, but ignores const
closeEnough :: CType -> CType -> Bool closeEnough :: CType -> CType -> Bool
closeEnough (Const t) t' = closeEnough t t' closeEnough (Const t) t' = closeEnough t t'
closeEnough t (Const t') = closeEnough t t' closeEnough t (Const t') = closeEnough t t'
closeEnough t t' = 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, -- Given some code to generate, and its type, and the type that you actually want,
-- adds the required decorators. Only pass it simplified types! -- adds the required decorators. Only pass it simplified types!
dressUp :: Meta -> (CGen (), CType) -> CType -> CGen () dressUp :: Meta -> (CGen (), CType) -> CType -> CGen ()
dressUp _ (gen, t) t' | t `closeEnough` t' = gen dressUp _ (gen, t) t' | t `closeEnough` t' = gen
--Every line after here is not close enough, so we know equality fails: --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, Pointer t) (Pointer t')
= dressUp m (gen, t) t' = dressUp m (gen, t) t'
dressUp m (gen, Const t) t' dressUp m (gen, Const t) t'
@ -267,3 +269,13 @@ dressUp m (gen, t@(Plain {})) (Pointer t')
= dressUp m (tell ["(&("] >> gen >> tell ["))"], t) t' = dressUp m (tell ["(&("] >> gen >> tell ["))"], t) t'
dressUp m (gen, Pointer t) t'@(Plain {}) dressUp m (gen, Pointer t) t'@(Plain {})
= dressUp m (tell ["(*("] >> gen >> tell ["))"], t) t' = 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]