diff options
Diffstat (limited to 'src/Language/Fiddle/Compiler/Backend/C.hs')
| -rw-r--r-- | src/Language/Fiddle/Compiler/Backend/C.hs | 136 |
1 files changed, 130 insertions, 6 deletions
diff --git a/src/Language/Fiddle/Compiler/Backend/C.hs b/src/Language/Fiddle/Compiler/Backend/C.hs index 79c81b1..a10839a 100644 --- a/src/Language/Fiddle/Compiler/Backend/C.hs +++ b/src/Language/Fiddle/Compiler/Backend/C.hs @@ -11,6 +11,7 @@ import Control.Monad (unless) import Control.Monad.RWS import Control.Monad.State import Control.Monad.Trans.Writer (Writer, execWriter) +import qualified Data.Bits import Data.Char (isSpace) import Data.Data (Typeable, cast) import Data.Foldable (forM_, toList) @@ -24,6 +25,7 @@ import qualified Data.Set as Set import Data.String (IsString) import Data.Text (Text) import qualified Data.Text as Text +import Data.Word import Language.Fiddle.Ast import Language.Fiddle.Compiler.Backend import Language.Fiddle.Compiler.Backend.Internal @@ -33,6 +35,7 @@ import Language.Fiddle.Compiler.Backend.Internal.Writer import Language.Fiddle.Internal.UnitInterface import Language.Fiddle.Internal.UnitNumbers import Language.Fiddle.Types +import Numeric (showHex) import Options.Applicative import Text.Printf (printf) @@ -324,7 +327,7 @@ writeBitsSet :: N Bits -> RegisterBitsTypeRef 'Checked I A -> M () -writeBitsSet structName bitsNam fullPath offset typeRef = do +writeBitsSet structName bitsName fullPath offset typeRef = do text "inline static void " text (qualifiedPathToIdentifier fullPath) text "__set(\n struct " @@ -332,7 +335,75 @@ writeBitsSet structName bitsNam fullPath offset typeRef = do text " *o,\n " typeRefToArgs typeRef text ") {\n" + + let shiftArguments = + zipWith + (\a b -> if b == 1 then a else a <> " * " <> s b) + (tail setterArgumentNames) + (snd $ offsetCoefficients typeRef) + ++ [s offset | offset /= 0] + + withIndent $ do + text $ maskValue typeRef + + text "int to_set = value" + + unless (null shiftArguments) $ do + text " << " + text $ Text.intercalate " + " shiftArguments + + text ";\n" + text $ "o->" <> Text.pack bitsName <> " = to_set;\n" text "}\n\n" + where + offsetCoefficients :: RegisterBitsTypeRef Checked I A -> (Int, [Int]) + offsetCoefficients + RegisterBitsJustBits + { justBitsExpr = fromIntegral . trueValue -> sz + } = (sz, []) + offsetCoefficients + RegisterBitsReference + { bitsRefQualificationMetadata = + Identity + ( Present + ( ExportedBitsDecl + { exportedBitsDeclSizeBits = sz + } + ) + ) + } = (fromIntegral sz, []) + offsetCoefficients (RegisterBitsArray tr n _) = + let (recsz, rest) = offsetCoefficients tr + in ( recsz * fromIntegral (trueValue n), + rest ++ [recsz] + ) + + s :: (Show a) => a -> Text + s = Text.pack . show + + maskValue ref = do + typeRefToMask ref + + typeRefToMask :: RegisterBitsTypeRef Checked I a -> Text + typeRefToMask RegisterBitsArray {bitsArrayTypeRef = ref} = typeRefToMask ref + typeRefToMask + RegisterBitsJustBits + { justBitsExpr = fromIntegral . trueValue -> sz + } = "value &= 0x" <> Text.pack (showHex (((1 :: Int) `Data.Bits.shiftL` (sz :: Int)) - 1) "") <> ";\n" + typeRefToMask + RegisterBitsReference + { bitsRefQualificationMetadata = + Identity + ( Present + ( ExportedBitsDecl + { exportedBitsDeclSizeBits = sz + } + ) + ) + } = + let num :: Int + num = (1 `Data.Bits.shiftL` fromIntegral sz) - 1 + in "value = (typeof(value))(value & 0x" <> Text.pack (showHex num "") <> ");\n" typeRefToArgs :: RegisterBitsTypeRef 'Checked I A -> M () typeRefToArgs reg = @@ -352,7 +423,11 @@ typeRefToArgs reg = ( RegisterBitsReference { bitsRefQualificationMetadata = (Identity (Present md)) } - ) = [qualifiedPathToIdentifier $ metadataFullyQualifiedPath $ getMetadata md] + ) = + [ "enum " + <> qualifiedPathToIdentifier + (metadataFullyQualifiedPath $ getMetadata md) + ] typeRefToArgs' (RegisterBitsArray tr (ConstExpression (LeftV _) _) _) = typeRefToArgs' tr ++ ["int"] @@ -361,7 +436,7 @@ typeRefToArgs reg = 32 -> "uint32_t" 16 -> "uint16_t" 8 -> "uint8_t" - _ -> "unsigend" + _ -> "unsigned" -- | Decomposes a type ref into a type name (String) and a list of dimensions -- (in the case of being an array) @@ -370,15 +445,17 @@ typeRefToArgs reg = writeRegisterBody :: StructName -> QRegMetadata True -> RegisterBody Checked I A -> M () writeRegisterBody structName regmeta = walk_ registerWalk where + regName = basenamePart (regFullPath regmeta) + registerWalk :: forall t. (Walk t, Typeable t) => t I A -> M () registerWalk t = case () of () - | (Just (DefinedBitsP modifier bitsName fullPath offset typeRef)) <- castTS t -> do + | (Just (DefinedBitsP modifier _ fullPath offset typeRef)) <- castTS t -> do sequence_ $ selectByModifier modifier - ( writeBitsGet structName bitsName fullPath offset typeRef, - writeBitsSet structName bitsName fullPath offset typeRef + ( writeBitsGet structName regName fullPath offset typeRef, + writeBitsSet structName regName fullPath offset typeRef ) -- text $ @@ -512,6 +589,45 @@ emitDocComments (Commented comments _) = do then Text.tail t else t +getEnumConstants :: [EnumConstantDecl Checked I a] -> [(String, N Unitless)] +getEnumConstants = mapMaybe $ \case + EnumConstantDecl (identToString -> str) (trueValue -> val) _ -> Just (str, val) + _ -> Nothing + +pattern EnumPattern :: QualifiedPath String -> [(String, N Unitless)] -> FiddleDecl Checked I a +pattern EnumPattern qualifiedPath consts <- + BitsDecl + { bitsQualificationMetadata = + Identity + ( Present + ( ExportedBitsDecl + { exportedBitsDeclMetadata = + Metadata + { metadataFullyQualifiedPath = qualifiedPath + } + } + ) + ), + bitsType = + EnumBitType + { enumBitBody = + Identity + ( EnumBody + { enumConsts = getEnumConstants . map undirected -> consts + } + ) + } + } + +emitEnum :: QualifiedPath String -> [(String, N Unitless)] -> M () +emitEnum (qualifiedPathToIdentifier -> ident) consts = do + text $ "enum " <> ident <> " " + body $ do + forM_ consts $ \(name, val) -> do + text $ + ident <> "__" <> Text.pack name <> " = " <> Text.pack (show val) <> ",\n" + text ";\n\n" + transpileWalk :: Either ImplementationInHeader FilePath -> FilePath -> @@ -545,6 +661,14 @@ transpileWalk _ headerFile t _ = case () of text $ Text.pack $ printf " ((%s*)0x%08x)\n" (toLiteralTypeName (exportedObjectDeclType e)) (exportedObjectDeclLocation e) return Stop + () | Just (EnumPattern path consts) <- castTS t -> do + checkout sF $ emitEnum path consts + return Stop + () | Just (ImportStatement {importPath = path}) <- castTS t -> do + let header = fst (Text.breakOnEnd "." path) <> "h" + in checkout hF $ do + text $ Text.pack $ printf "#include \"%s\"\n" header + return Stop _ -> return (Continue ()) where toLiteralTypeName :: ReferencedObjectType -> Text |