{- ShiftDriver: Mackerel backend for device drivers Part of Mackerel: a strawman device definition DSL for Barrelfish Copyright (c) 2007, 2008, 2010, ETH Zurich. All rights reserved. This file is distributed under the terms in the attached LICENSE file. If you do not find this file, copies can be found by writing to: ETH Zurich D-INFK, Universitaetstrasse 6, CH-8092 Zurich. Attn: Systems Group. -} module ShiftDriver where import System.IO import System.Exit import Data.List import Data.Bits import Text.Printf import MackerelParser import Checks import Attr import qualified Space import qualified CAbsSyntax as C import qualified TypeName as TN import qualified TypeTable as TT import qualified RegisterTable as RT import qualified Fields import qualified Dev ------------------------------------------------------------------------ -- Standardized names of C variables ------------------------------------------------------------------------ cv_i = "_i" -- Index for register arrays cv_dev = "_dev" -- Device structure cv_avail = "_avail" -- Available buffer space for snprintf cv_size = "_size" -- Size of buffer for snprintf cv_s = "_s" -- Buffer ptr for snprint cv_rc = "_rc" -- Return value from snprintf cv_r = "_r" -- Accumulator for snprintf values cv_regval = "_regval" -- Value of type register contents cv_fieldval = "_fieldval" -- Value of type field contents cv_dtptr = "_dtptr" -- Value of type pointer to datatype struct cv_e = "_e" -- Enumeration type value ------------------------------------------------------------------------- -- The C Language mapping: top level name definitions ------------------------------------------------------------------------- -- -- Device-related names -- device_c_name :: String device_c_name = "__DN(t)" device_shadow_field_name :: RT.Rec -> String device_shadow_field_name rt = (RT.name rt) ++ "_shadow" device_initialize_fn_name :: Dev.Rec -> String device_initialize_fn_name d = qual_devname d [ "initialize" ] device_print_fn_name :: Dev.Rec -> String device_print_fn_name d = qual_devname d [ "pr" ] device_prefix_macro_name :: Dev.Rec -> String device_prefix_macro_name d = qual_devname d ["PREFIX"] device_initial_enum_name :: Dev.Rec -> String device_initial_enum_name d = qual_devname d ["initials"] -- -- Space-related names -- space_read_fn_name :: Space.Rec -> Integer -> String space_read_fn_name s w = printf "__DN(%s)" (concat $ intersperse "_" [ Space.n s, "read", show w ]) space_write_fn_name :: Space.Rec -> Integer -> String space_write_fn_name s w = printf "__DN(%s)" (concat $ intersperse "_" [ Space.n s, "write", show w ]) space_cpu_reg_read_fn_name :: Space.Rec -> Integer -> String -> String space_cpu_reg_read_fn_name s w n = printf (concat $ intersperse "_" [ Space.n s, "read", show w, n ]) space_cpu_reg_write_fn_name :: Space.Rec -> Integer -> String -> String space_cpu_reg_write_fn_name s w n = printf (concat $ intersperse "_" [ Space.n s, "write", show w, n ]) -- -- Constants-related names -- constants_c_name :: TT.Rec -> String constants_c_name c = qual_typerec c ["t"] constants_elem_c_name :: TT.Val -> String constants_elem_c_name v = qual_device (TT.ctype v) [ TT.cname v ] constants_print_fn_name :: TN.Name -> String constants_print_fn_name c = qual_typename c ["prtval"] constants_describe_fn_name :: TT.Rec -> String constants_describe_fn_name c = qual_typerec c ["describe" ] -- -- Register and datatype-related names -- regtype_c_name :: TT.Rec -> String regtype_c_name rt | TT.is_builtin rt = (TN.typeName $ TT.tt_name rt) ++ "_t" | otherwise = qual_typerec rt ["t"] regtype_initial_macro_name :: TT.Rec -> String regtype_initial_macro_name rt = qual_typerec rt ["default"] regtype_extract_fn_name :: TT.Rec -> Fields.Rec -> String regtype_extract_fn_name rt f = qual_typerec rt [ Fields.name f, "extract" ] regtype_insert_fn_name :: TT.Rec -> Fields.Rec -> String regtype_insert_fn_name rt f = qual_typerec rt [ Fields.name f, "insert" ] regtype_print_fn_name :: TT.Rec -> String regtype_print_fn_name rt = qual_typerec rt [ "prtval"] datatype_array_c_name :: TT.Rec -> String datatype_array_c_name rt = qual_typerec rt [ "array", "t"] datatype_size_macro_name :: TT.Rec -> String datatype_size_macro_name rt = qual_typerec rt ["size"] -- -- Register- and register array-related names -- register_initial_name :: RT.Rec -> String register_initial_name r = qual_register r [ "initial" ] register_read_fn_name :: RT.Rec -> String register_read_fn_name r = qual_register r ["rd"] register_write_fn_name :: RT.Rec -> String register_write_fn_name r = qual_register r ["wr"] register_rawread_fn_name :: RT.Rec -> String register_rawread_fn_name r = qual_register r ["rawrd"] register_rawwrite_fn_name :: RT.Rec -> String register_rawwrite_fn_name r = qual_register r ["rawwr"] register_shadow_name :: RT.Rec -> String register_shadow_name r = qual_register r ["shadow"] register_c_name :: RT.Rec -> String register_c_name r = regtype_c_name $ RT.tpe r field_c_name :: Fields.Rec -> String field_c_name f = case Fields.tpe f of Nothing -> round_field_size $ Fields.size f Just t -> qual_typename t ["t"] register_print_fn_name :: RT.Rec -> String register_print_fn_name rt = qual_register rt ["pr"] register_read_field_fn_name :: RT.Rec -> Fields.Rec -> String register_read_field_fn_name r f = qual_register r [ Fields.name f, "rdf"] register_read_field_from_shadow_fn_name :: RT.Rec -> Fields.Rec -> String register_read_field_from_shadow_fn_name r f = qual_register r [Fields.name f, "rd", "shadow"] register_write_field_fn_name :: RT.Rec -> Fields.Rec -> String register_write_field_fn_name r f = qual_register r [ Fields.name f, "wrf"] regarray_length_macro_name :: RT.Rec -> String regarray_length_macro_name r = qual_register r [ "length" ] regarray_print_fn_name :: RT.Rec -> String regarray_print_fn_name rt = qual_register rt ["pri"] ------------------------------------------------------------------------- -- Convenience functions for generating the C mapping ------------------------------------------------------------------------- -- -- Given a field width in bits, return the C type of the smallest -- possible unsigned integer capable of holding it. -- round_field_size w | w <= 8 = "uint8_t" | ( w > 8 && w <= 16 ) = "uint16_t" | ( w > 16 && w <= 32 ) = "uint32_t" | otherwise = "uint64_t" -- -- Take a list of scope names and translate to a C identifier. -- qual_devname :: Dev.Rec -> [ String ] -> String qual_devname d l = concat $ intersperse "_" ([Dev.name d] ++ l) qual_device :: TN.Name -> [ String ] -> String qual_device t l = concat $ intersperse "_" ([TN.devName t] ++ l) qual_typename :: TN.Name -> [ String ] -> String qual_typename (TN.Name dn tn) l = concat $ intersperse "_" ([dn, tn] ++ l) qual_typerec :: TT.Rec -> [ String ] -> String qual_typerec t l = qual_typename (TT.tt_name t) l qual_register :: RT.Rec -> [ String ] -> String qual_register r l = qual_device (RT.typename r) ([RT.name r] ++ l) -- -- Generate a simple automatic variable declaration with optional initializer. -- simple_var :: String -> String -> Maybe C.Expr -> C.Stmt simple_var t n e = C.VarDecl C.NoScope C.NonConst (C.TypeName t) n e -- -- Generate a simple for loop with i = 0 to something. -- simple_for :: C.Expr -> [ C.Stmt ] -> C.Stmt simple_for end body = C.For (C.Assignment (C.Variable cv_i) (C.NumConstant 0)) (C.Binary C.LessThan (C.Variable cv_i) end) (C.PostInc (C.Variable cv_i)) body -- -- Given a field width in bits, return the C snprintf format -- specifying to correctly format it. -- field_fmt_str size | size <= 8 = "PRIx8" | size <= 16 = "PRIx16" | size <= 32 = "PRIx32" | otherwise = "PRIx64" -- -- Percent-escape a string so it can be used in a format to snprintf. -- percent_escape :: String -> String percent_escape s = concat [ if c == '%' then "%%" else [c] | c <- s ] -- -- Define a static inline function which looks like an snprintf in its -- calling conventions, and maintains its internal buffer variables -- accordingly. -- snprintf_like_defn :: String -> [ C.Param ] -> [ C.Stmt ] -> C.Unit snprintf_like_defn name extra_args main_body = C.StaticInline (C.TypeName "int") name args body where args = [ C.Param (C.Ptr $ C.TypeName "char") cv_s, C.Param (C.TypeName "size_t") cv_size ] ++ extra_args body = [ simple_var "int" cv_r (Just $ C.NumConstant 0), simple_var "int" cv_avail Nothing, simple_var "int" cv_rc Nothing ] ++ main_body ++ [ C.Return $ C.Variable cv_r ] -- -- Wrap a call to a function which acts like snprintf (i.e. takes a -- buffer, and a size, and tries to fit the output into the buffer). -- The code generated here can be safely nested inside another -- snprintf-like function as long as the variable names 'avail', -- 'size', 'r', and 'rc' are declared. -- snprintf_like_call :: String -> [C.Expr] -> C.Stmt snprintf_like_call n a = C.StmtList [ C.Ex $ C.Assignment (C.Variable cv_avail) $ C.Ternary (C.Binary C.GreaterThan (C.Variable cv_r) (C.Variable cv_size)) (C.NumConstant 0) (C.Binary C.Minus (C.Variable cv_size) (C.Variable cv_r)), C.Ex $ C.Assignment (C.Variable cv_rc) (C.Call n ([ C.Binary C.Plus (C.Variable cv_s) (C.Variable cv_r), C.Variable cv_avail ] ++ a)), C.If (C.Binary C.And (C.Binary C.GreaterThan (C.Variable cv_rc) (C.NumConstant 0)) (C.Binary C.LessThan (C.Variable cv_rc) (C.Variable cv_avail))) [ C.Ex $ C.Assignment (C.Variable cv_r) (C.Binary C.Plus (C.Variable cv_r) (C.Variable cv_rc)) ] [] ] snputs_like_call :: String -> C.Stmt snputs_like_call s = snprintf_like_call "snprintf" [ C.StringConstant $ percent_escape s ] -- -- Functions to generate masks to select or deselect a subfield of bits -- select_mask :: (Num a, Bits a) => Integer -> Integer -> Integer -> a select_mask word_size start width = foldl setBit 0 (enumFromTo (fromInteger $ start) (fromInteger $ start + width - 1)) deselect_mask :: (Num a, Bits a) => Integer -> Integer -> Integer -> a deselect_mask word_size start width = foldl complementBit (select_mask word_size start width) (enumFromTo 0 (fromInteger word_size - 1)) -- -- Functions to generate the builtin Mackerel access functions -- mackerel_read_fn_name :: String -> Integer -> String mackerel_read_fn_name typename size = printf "mackerel_read_%s_%s" typename (show size) mackerel_write_fn_name :: String -> Integer -> String mackerel_write_fn_name typename size = printf "mackerel_write_%s_%s" typename (show size) -- -- Generate a string describing a register field -- field_dump :: Fields.Rec -> String field_dump f = printf " %s\t(size %d, offset %d, init %x):\t%s\t%s" (Fields.name f) (Fields.size f) (Fields.offset f) (Fields.initial f) (show $ Fields.attr f) (Fields.desc f ) -- translation function mapped to every argument, for generic conversion -- (eg. types or names) before rendering those arguments in C code convert_arg (Arg "addr" x) = Arg "mackerel_addr_t" x convert_arg (Arg "pci" x) = Arg "mackerel_pci_t" x convert_arg (Arg "io" x) = Arg "mackerel_io_t" x ------------------------------------------------------------------------- -- Top-level header file rendering code ------------------------------------------------------------------------- -- Top-level create-a-header-file compile :: String -> String -> Dev.Rec -> String compile infile outfile dev = unlines $ C.pp_unit $ device_header_file dev infile device_header_file_string :: Dev.Rec -> String -> String device_header_file_string d hdr = unlines $ C.pp_unit $ device_header_file d hdr device_header_file :: Dev.Rec -> String -> C.Unit device_header_file d hdr = let sym = "__" ++ (Dev.name d) ++ "_DEV_H" in C.IfNDef sym ([ C.Define sym [] "1"] ++ (device_def d hdr)) [] -- Body of the generated file device_def :: Dev.Rec -> String -> [ C.Unit ] device_def dev header = ( [device_preamble dev] ++ std_header_files dev ++ device_prefix_defs dev ++ concat [ constants_decl d | d@(TT.ConstType {}) <- Dev.types dev] ++ concat [ regtype_decl d | d@(TT.RegFormat {}) <- Dev.types dev ] ++ concat [ datatype_decl d | d@(TT.DataFormat {}) <- Dev.types dev] ++ (device_struct_def dev) ++ (device_initial_values dev) ++ (device_initialize_fn dev) ++ -- Not currently implemented in command line opts -- (device_space_includes dev header) -- ++ concat [ register_decl d | d <- (Dev.registers dev) ] ++ [(device_print_fn dev)] ++ (device_prefix_undefs dev) ) device_preamble :: Dev.Rec -> C.Unit device_preamble dev = C.MultiComment [ "DEVICE DEFINITION: " ++ (Dev.desc dev), "", "Copyright (c) 2010, ETH Zurich.", "All rights reserved.", "", "This file is distributed under the terms in the attached LICENSE", "file. If you do not find this file, copies can be found by", "writing to:", "ETH Zurich D-INFK, Universitaetstrasse 6, CH-8092 Zurich.", "Attn: Systems Group.", "", "THIS FILE IS AUTOMATICALLY GENERATED BY MACKEREL: DO NOT EDIT!" ] device_c_type :: C.TypeSpec device_c_type = C.TypeName device_c_name -- Undefine macros used by the header file device_prefix_undefs :: Dev.Rec -> [ C.Unit ] device_prefix_undefs d = [ C.Undef "__DN" ] -- Define macros used by the header file device_prefix_defs :: Dev.Rec -> [ C.Unit ] device_prefix_defs d = let name = Dev.name d prefix = device_prefix_macro_name d in (device_prefix_undefs d) ++ [ C.Define "__DN" ["x"] (name ++ " ## _ ## x") ] -- Header files info std_header_files :: Dev.Rec -> [ C.Unit ] std_header_files dev = map (C.Include C.Standard) inclist where inclist = [ "mackerel/mackerel.h", "inttypes.h" ] ++ [ i ++ "_dev.h" | i <- Dev.imports dev ] -- Device representation structure generator device_struct_def :: Dev.Rec -> [ C.Unit ] device_struct_def d = [ C.MultiComment ["Device representation structure"], C.StructDecl device_c_name params, C.TypeDef (C.Struct device_c_name) device_c_name ] where params = [ C.Param (C.TypeName n) v | Arg n v <- map convert_arg (Dev.args d) ] ++ [ device_struct_shadow_field r | r <- RT.get_shadow_registers $ Dev.registers d ] device_struct_shadow_field :: RT.Rec -> C.Param device_struct_shadow_field rt = let t = if RT.is_array rt then C.Array (RT.num_elements rt) (regtype_c_type $ RT.tpe rt) else regtype_c_type $ RT.tpe rt in C.Param t (device_shadow_field_name rt) device_initial_values :: Dev.Rec -> [ C.Unit ] device_initial_values d@( Dev.Rec{ Dev.registers = [] } ) = [ C.Blank, C.Comment "No registers in this device", C.Blank ] device_initial_values d = [ C.Blank, C.MultiComment ["Initial register values (currently 0)"], C.EnumDecl (device_initial_enum_name d) [ C.EnumItem (register_initial_name r) (Just $ C.HexConstant $ 0) | r <- (Dev.registers d) ], C.Blank ] device_initialize_field :: RT.Rec -> C.Stmt device_initialize_field rt = let val = C.Variable $ register_initial_name rt in if RT.is_array rt then C.Block [ simple_var "int" cv_i Nothing, simple_for (C.NumConstant $ RT.num_elements rt) [ C.Ex $ C.Assignment (regarray_shadow_ref rt) val ] ] else C.Ex $ C.Assignment (register_shadow_ref rt) val device_initialize_arg :: String -> C.Stmt device_initialize_arg v = C.Ex $ C.Assignment (C.DerefField (C.Variable cv_dev) v) (C.Variable v) -- Device init function device_initialize_fn :: Dev.Rec -> [ C.Unit ] device_initialize_fn d = [ C.MultiComment [ "Device Initialization function" ], C.StaticInline C.Void (device_initialize_fn_name d) params body ] where args = Dev.args d params = [ C.Param (C.Ptr device_c_type) cv_dev ] ++ [ C.Param (C.TypeName n) v | (Arg n v) <- map convert_arg args ] body = [ device_initialize_arg v | (Arg _ v) <- args ] -- XXX: Shadow copy initialization broken -- ++ -- [ device_initialize_field rt -- | rt <- RT.get_shadow_registers $ Dev.registers d ] device_print_fn :: Dev.Rec -> C.Unit device_print_fn d = snprintf_like_defn (device_print_fn_name d) args body where args = [ C.Param (C.Ptr device_c_type) cv_dev ] body = [ snputs_like_call "-------------------------\n", snputs_like_call (printf "Dump of device %s (%s):\n" (Dev.name d) (percent_escape (Dev.desc d))) ] ++ [ device_print_eachreg r | r <- (Dev.registers d)] ++ [ snputs_like_call (printf "End of dump of device %s\n" (Dev.name d) ), snputs_like_call "-------------------------\n" ] device_print_eachreg r = snprintf_like_call (register_print_fn_name r) [ C.Variable cv_dev ] -- XXX: This needs more thorough examination. I don't know how the -- commandline is interacting with device spaces. Currently, when -- there are no device spaces defined, the commandline is ignored. device_space_includes :: Dev.Rec -> String -> [ C.Unit ] device_space_includes d header | all Space.is_builtin (Dev.spaces d) = [ C.MultiComment [ "No user-defined spaces" ] ] | header /= "" = [ C.MultiComment [ "Space access include overridden by cmd line:"], C.Include C.Local header ] | otherwise = [ C.MultiComment [ "Include access functions for user-defined spaces"], C.Include C.Local $ printf "%s_spaces.h" (Dev.name d) ] ------------------------------------------------------------------------- -- Render 'constants' declarations ------------------------------------------------------------------------- -- -- Everything we need for a constants definition -- constants_decl :: TT.Rec -> [ C.Unit ] constants_decl c = [ constants_comment c, constants_typedef c ] ++ ( constants_enum c ) ++ [ C.Blank, constants_describe_fn c, constants_print_fn c ] constants_c_type :: TT.Rec -> C.TypeSpec constants_c_type c = C.TypeName $ constants_c_name c constants_comment :: TT.Rec -> C.Unit constants_comment c = C.MultiComment [ printf "Constants defn: %s (%s)" (TN.toString $ TT.tt_name c) (TT.tt_desc c), case TT.tt_width c of Nothing -> " - no width specified" Just w -> printf " - width %d bits" w ] constants_enum :: TT.Rec -> [ C.Unit ] constants_enum c = [ C.Define (constants_elem_c_name v) [] (constants_eval c v) | v <- TT.tt_vals c ] constants_typedef :: TT.Rec -> C.Unit constants_typedef c = C.TypeDef (C.TypeName $ round_field_size $ TT.tt_size c) (constants_c_name c) constants_eval :: TT.Rec -> TT.Val -> String constants_eval c v = printf "((%s)%s)" (constants_c_name c) (case TT.cval v of ExprConstant (-1) -> "(-1LL)" ExprConstant i -> printf "0x%x" i ) constants_print_fn :: TT.Rec -> C.Unit constants_print_fn c = C.StaticInline (C.TypeName "int") (constants_print_fn_name $ TT.tt_name c) [ C.Param (C.Ptr $ C.TypeName "char") cv_s, C.Param (C.TypeName "size_t") cv_size, C.Param (constants_c_type c) cv_e ] [ C.VarDecl C.NoScope C.NonConst (C.Ptr $ C.TypeName "char") "d" (Just $ C.Call (constants_describe_fn_name c) [ C.Variable cv_e ]), C.If (C.Variable "d") [ C.Return $ C.Call "snprintf" [ C.Variable cv_s, C.Variable cv_size, C.StringConstant "%s", C.Variable "d" ] ] [ C.Return $ C.Call "snprintf" [ C.Variable cv_s, C.Variable cv_size, C.StringCat [ C.QStr "Unknown constant %s value 0x%", C.NStr "PRIx64" ], C.StringConstant (constants_c_name c), C.Cast (C.TypeName "uint64_t") (C.Variable cv_e) ] ] ] constants_describe_fn :: TT.Rec -> C.Unit constants_describe_fn c = let rep v = C.StringConstant $ printf "%s: %s" (TT.cname v) (TT.cdesc v) in C.StaticInline (C.Ptr $ C.TypeName "char") (constants_describe_fn_name c) [ C.Param (constants_c_type c) cv_e ] [ C.Switch (C.Variable cv_e) [ C.Case (C.Variable $ constants_elem_c_name v) [ C.Return $ rep v ] | v <- TT.tt_vals c ] [ C.Return $ C.Variable "NULL" ] ] ------------------------------------------------------------------------- -- Render register type definitions ------------------------------------------------------------------------- regtype_c_type :: TT.Rec -> C.TypeSpec regtype_c_type rt = C.TypeName $ regtype_c_name rt -- -- All the generated declarations for a register type. -- regtype_decl :: TT.Rec -> [ C.Unit ] regtype_decl rt = [ regtype_dump rt, regtype_typedef rt, regtype_initial_macro rt ] ++ (regtype_access_fns rt) ++ [ regtype_print_fn rt ] -- -- Emit a comment describing the register type. -- regtype_dump :: TT.Rec -> C.Unit regtype_dump rt = C.MultiComment ([ (TT.type_kind rt) ++ " type: " ++ (regtype_c_name rt), "Description: " ++ (TT.tt_desc rt), "Fields:" ] ++ [ field_dump f | f <- TT.fields rt ]) -- -- Calculate an appropriate built-in type for a mackerel type -- regtype_c_builtin :: TT.Rec -> C.TypeSpec regtype_c_builtin rt = C.TypeName $ round_field_size $ TT.tt_size rt -- -- Define the register type to be an unsigned integer of appropriate size -- regtype_typedef :: TT.Rec -> C.Unit regtype_typedef rt = C.TypeDef (regtype_c_builtin rt) (regtype_c_name rt) -- -- Emit macro for initial register value -- regtype_initial_macro :: TT.Rec -> C.Unit regtype_initial_macro rt = C.Define sym [] (C.pp_expr $ C.HexConstant val) where sym = regtype_initial_macro_name rt fields = TT.fields rt val = foldl (.|.) 0 [ Fields.initial_mask f | f <- fields ] -- -- Emit functions to extract and insert each field from a value of -- register contents. -- regtype_access_fns :: TT.Rec -> [ C.Unit ] regtype_access_fns rt = concat [ [ regtype_field_extract_fn rt f, regtype_field_insert_fn rt f ] | f <- TT.fields rt, not $ Fields.is_anon f ] -- -- Return the C type name for a field or a register -- field_c_type :: Fields.Rec -> C.TypeSpec field_c_type f = C.TypeName $ field_c_name f -- -- Emit a function to extract a field from a register type value -- regtype_field_extract_fn :: TT.Rec -> Fields.Rec -> C.Unit regtype_field_extract_fn rt f = let t = field_c_type f n = regtype_extract_fn_name rt f sz = TT.tt_size rt arg = C.Param (regtype_c_type rt) cv_regval -- ( r & (Fields.extract_mask f) ) >> (Fields.extract_shift f) body = C.Return $ C.Cast t (C.Binary C.RightShift (C.Binary C.BitwiseAnd (C.Variable cv_regval) (C.HexConstant $ Fields.extract_mask f sz)) (C.NumConstant $ Fields.offset f)) in C.StaticInline t n [ arg ] [ body ] -- -- Emit a function to insert a field value into a register type value -- regtype_field_insert_fn :: TT.Rec -> Fields.Rec -> C.Unit regtype_field_insert_fn rt f = let t = field_c_type f n = regtype_insert_fn_name rt f rtn = regtype_c_type rt sz = TT.tt_size rt arg1 = C.Param rtn cv_regval arg2 = C.Param t cv_fieldval -- return (r & Fields.insert_mask f) | ((rtn)v << (Fields.offset f) & (Fields.insert_mask f)) -- Note that we cast the field type to the register type, to -- ensure that it's large enough when we do the shift body = C.Return $ C.Binary C.BitwiseOr (C.Binary C.BitwiseAnd (C.Variable cv_regval) (C.HexConstant $ Fields.insert_mask f sz) ) (C.Binary C.BitwiseAnd (C.HexConstant $ Fields.extract_mask f sz) (C.Binary C.LeftShift (C.Cast rtn (C.Variable cv_fieldval)) (C.NumConstant $ Fields.offset f))) in C.StaticInline rtn n [ arg1, arg2 ] [ body ] -- -- Print out a value of the register or data type -- regtype_print_fn :: TT.Rec -> C.Unit regtype_print_fn rt = snprintf_like_defn (regtype_print_fn_name rt) args body where fields = TT.fields rt args = [ C.Param (regtype_c_type rt) cv_regval ] body = [ field_print_block rt f | f <- fields, not $ Fields.is_anon f ] -- -- Return a statement (or list) which will correctly format a register -- field as part of a larger snprintf-like function. -- field_print_block :: TT.Rec -> Fields.Rec -> C.Stmt field_print_block _ f@(Fields.Rec { Fields.is_anon = True }) = C.SComment ((Fields.name f) ++ " is anonymous") field_print_block rt f = case Fields.tpe f of Nothing -> let fmt = C.StringCat [ C.QStr $ printf " %s =\t%%" (Fields.name f), C.NStr (field_fmt_str $ Fields.size f), C.QStr $ printf "\t(%s)\n" (percent_escape $ Fields.desc f) ] val = C.Call (regtype_extract_fn_name rt f) [ C.Variable cv_regval ] in snprintf_like_call "snprintf" [fmt, val] Just t -> C.StmtList [snputs_like_call $ printf " %s =\t" (Fields.name f), snprintf_like_call (constants_print_fn_name t) [ C.Call (regtype_extract_fn_name rt f) [(C.Variable cv_regval)] ], snputs_like_call $ printf "\t(%s)\n" (Fields.desc f) ] ------------------------------------------------------------------------- -- Render data type definitions ------------------------------------------------------------------------- datatype_decl :: TT.Rec -> [ C.Unit ] datatype_decl dt = [ regtype_dump dt, datatype_typedef dt, datatype_array_typedef dt, datatype_size_macro dt ] ++ datatype_access_fns dt ++ [ regtype_print_fn dt ] datatype_typedef :: TT.Rec -> C.Unit datatype_typedef dt = C.TypeDef (C.Ptr $ C.TypeName "uint8_t") (regtype_c_name dt) datatype_array_typedef :: TT.Rec -> C.Unit datatype_array_typedef dt = let sz = ((TT.tt_size dt) + 7) `div` 8 in C.TypeDef (C.Array sz $ C.TypeName "uint8_t") (datatype_array_c_name dt) datatype_size_macro :: TT.Rec -> C.Unit datatype_size_macro dt = C.GVarDecl C.Static C.Const (C.TypeName "size_t") (datatype_size_macro_name dt) (Just $ C.SizeOfT $ C.TypeName $ datatype_array_c_name dt) datatype_field_load_size :: Fields.Rec -> Integer datatype_field_load_size Fields.Rec {Fields.offset=o, Fields.size=s} | s + (o `mod` 8) <= 8 = 8 | s + (o `mod` 16) <= 16 = 16 | s + (o `mod` 32) <= 32 = 32 | s + (o `mod` 64) <= 64 = 64 | otherwise = 0 -- -- Emit functions to extract and insert each field from a value of -- register contents. -- datatype_access_fns :: TT.Rec -> [ C.Unit ] datatype_access_fns rt = concat [ [ datatype_field_extract_fn rt f, datatype_field_insert_fn rt f ] | f <- TT.fields rt, not $ Fields.is_anon f ] -- -- Emit a function to extract a field from a data type value -- datatype_field_extract_fn :: TT.Rec -> Fields.Rec -> C.Unit datatype_field_extract_fn rt f = let t = field_c_type f n = regtype_extract_fn_name rt f arg = C.Param (regtype_c_type rt) cv_dtptr load_size = datatype_field_load_size f bits_offset = (Fields.offset f) `mod` load_size word_offset = ((Fields.offset f) - bits_offset) `div` 8 mask = select_mask load_size bits_offset (Fields.size f) load_c_type = C.TypeName $ round_field_size load_size -- ( r & (Fields.extract_mask f) ) >> (Fields.extract_shift f) body = C.Return $ C.Binary C.RightShift (C.Binary C.BitwiseAnd (C.DerefPtr (C.Cast (C.Ptr load_c_type) (C.Binary C.Plus (C.NumConstant word_offset) (C.Variable cv_dtptr)))) (C.HexConstant $ mask)) (C.NumConstant $ bits_offset) in C.StaticInline t n [ arg ] [ body ] -- -- Emit a function to insert a field value into a data type value -- datatype_field_insert_fn :: TT.Rec -> Fields.Rec -> C.Unit datatype_field_insert_fn rt f = let t = field_c_type f n = regtype_insert_fn_name rt f rtn = C.TypeName $ round_field_size $ TT.wordsize rt arg1 = C.Param (regtype_c_type rt) cv_dtptr arg2 = C.Param t cv_fieldval load_size = datatype_field_load_size f bits_offset = (Fields.offset f) `mod` load_size word_offset = ((Fields.offset f) - bits_offset) `div` 8 smask = select_mask load_size bits_offset (Fields.size f) dmask = deselect_mask load_size bits_offset (Fields.size f) load_c_type = C.TypeName $ round_field_size load_size load_expr = (C.DerefPtr (C.Cast (C.Ptr load_c_type) (C.Binary C.Plus (C.NumConstant word_offset) (C.Variable cv_dtptr)))) -- return (r & Fields.insert_mask f) | (v << (Fields.offset f) & (Fields.insert_mask f)) body = C.Ex $ C.Assignment load_expr (C.Binary C.BitwiseOr (C.Binary C.BitwiseAnd load_expr (C.HexConstant dmask)) (C.Binary C.BitwiseAnd (C.HexConstant smask) (C.Binary C.LeftShift (C.Variable cv_fieldval) (C.NumConstant bits_offset) )) ) in C.StaticInline C.Void n [ arg1, arg2 ] [ body ] ------------------------------------------------------------------------- -- Render register definitions ------------------------------------------------------------------------- register_c_type :: RT.Rec -> C.TypeSpec register_c_type r = C.TypeName $ register_c_name r register_shadow_ref :: RT.Rec -> C.Expr register_shadow_ref r = let deref = C.DerefField (C.Variable cv_dev) (device_shadow_field_name r) in if RT.is_array r then C.SubscriptOf deref (C.Variable cv_i) else deref regarray_shadow_ref :: RT.Rec -> C.Expr regarray_shadow_ref rt = C.SubscriptOf (register_shadow_ref rt) (C.Variable cv_i) -- -- All the declarations for a given register. Note that all -- type-related stuff is handled above here by regtype_*; these -- declarations are specific to the register itself. -- register_decl :: RT.Rec -> [ C.Unit ] register_decl r = [ register_dump_comment r, regarray_length_macro r ] ++ ( register_rawread_fn r) ++ [ register_read_fn r ] ++ ( register_rawwrite_fn r) ++ [ register_write_fn r ] ++ ( register_print_fn r) ++ (if not $ TT.is_primitive $ RT.tpe r then [ register_read_field_fn r f | f <- RT.fl r, attr_user_can_read $ Fields.attr f ] ++ [ register_read_field_from_shadow_fn r f | f <- RT.fl r, attr_is_writeonly $ Fields.attr f ] ++ [ register_write_field_fn r f | f <- RT.fl r, attr_user_can_write $ Fields.attr f ] else [] ) register_dump_comment :: RT.Rec -> C.Unit register_dump_comment r = C.MultiComment ([name, typedesc] ++ fields) where title = if (RT.is_array r) then " array" else "" name = printf "Register%s %s: %s" title (RT.name r) (RT.desc r) typedesc = printf "Type: %s (%s)" (TN.toString $ RT.typename r) (if TT.is_primitive $ RT.tpe r then "primitive type" else TT.tt_desc $ RT.tpe r) fields = if TT.is_primitive $ RT.tpe r then [] else [ field_dump f | f <- RT.fl r ] -- -- Return a declaration for the length of a register array. -- regarray_length_macro :: RT.Rec -> C.Unit regarray_length_macro r | RT.is_array r = (C.GVarDecl C.Static C.Const (C.TypeName "size_t") (regarray_length_macro_name r) (Just $ C.NumConstant $ RT.num_elements r)) | otherwise = C.NoOp -- -- Do a raw read from a register, if the address is available. -- register_rawread_fn :: RT.Rec -> [ C.Unit ] register_rawread_fn r = let rtn = regtype_c_type $ RT.tpe r args = (register_arg_list [] r []) n = register_rawread_fn_name r raw_type = regtype_c_builtin $ RT.tpe r decl = loc_read_decl r raw_type args in if RT.is_noaddr r then [ C.Comment (printf "%s has no address, user must supply %s" (RT.name r) n) ] else if RT.is_readable r then [ decl, C.StaticInline rtn n args [ C.Return (loc_read r) ] ] else [ C.Comment $ printf "Register %s is not readale" (RT.name r) ] -- -- Read from the register, or from a shadow copy if it's not readable. -- register_read_fn :: RT.Rec -> C.Unit register_read_fn r = let rtn = regtype_c_type $ RT.tpe r name = register_read_fn_name r args = (register_arg_list [] r []) in if RT.is_readable r then C.StaticInline rtn name args [ C.Return (loc_read r) ] else C.StaticInline rtn name args [ C.Return (register_shadow_ref r) ] -- -- Do a write read top a register, if the address is available. -- register_rawwrite_fn :: RT.Rec -> [ C.Unit ] register_rawwrite_fn r = let rtn = regtype_c_type $ RT.tpe r args = register_arg_list [] r [ C.Param (regtype_c_type $ RT.tpe r) cv_regval ] n = register_rawwrite_fn_name r raw_type = (C.TypeName $ round_field_size $ TT.tt_size $ RT.tpe r) raw_args = register_arg_list [] r [ C.Param ( regtype_c_builtin $ RT.tpe r) cv_regval ] decl = loc_write_decl r raw_type raw_args in if RT.is_noaddr r then [ C.Comment (printf "%s has no address, user must supply %s" (RT.name r) n) ] else if RT.is_writeable r then [ decl, C.StaticInline C.Void n args [ C.Ex $ loc_write r cv_regval ] ] else [ C.Comment $ printf "Register %s is not writeable" (RT.name r) ] -- -- Write to register. Harder than it sounds. -- -- To do this properly involves: -- 1) Take the value to be written -- 2) AND together the MB0 and RSVD fields' insert masks, and AND this with -- the value. -- 3) OR together the MB1 fields' select masks, and OR this with the -- value. -- 4) OR together the RSVD fields' select masks. If this is non-zero, -- AND this mask with a read from the register, and OR this into the value. -- 5) Write this to the register, and to the shadow, if present. -- register_write_fn :: RT.Rec -> C.Unit register_write_fn r = let name = register_write_fn_name r args = register_arg_list [] r [ C.Param (regtype_c_type $ RT.tpe r) cv_regval ] fields = RT.fl r size = RT.size r nomask = 0xffffffffffffffff mb0mask :: Integer mb0mask = foldl (.&.) nomask [ Fields.insert_mask f size | f <- fields, (attr_zero_before_write $ Fields.attr f) || (attr_preserve_on_write $ Fields.attr f) ] mb1mask :: Integer mb1mask = foldl (.|.) 0 [ Fields.extract_mask f size | f <- fields, (attr_set_before_write $ Fields.attr f) ] prsvmask :: Integer prsvmask = foldl (.|.) 0 [ Fields.extract_mask f size | f <- fields, (attr_preserve_on_write $ Fields.attr f) ] body = [ (if mb0mask /= nomask then (C.Ex $ C.Assignment (C.Variable cv_regval) (C.Binary C.BitwiseAnd (C.Variable cv_regval) (C.HexConstant mb0mask))) else C.SComment "No MB0 or RSVD fields present" ), (if mb1mask /= 0 then (C.Ex $ C.Assignment (C.Variable cv_regval) (C.Binary C.BitwiseOr (C.Variable cv_regval) (C.HexConstant mb1mask))) else C.SComment "No MB1 fields present" ), (if prsvmask /= 0 then (if RT.is_readable r then (C.Ex $ C.Assignment (C.Variable cv_regval) (C.Binary C.BitwiseOr (C.Variable cv_regval) (C.Binary C.BitwiseAnd (C.HexConstant prsvmask) (loc_read r)))) else C.SComment "No pre-read. Register is write only." ) else C.SComment "No pre-read of register required" ), C.Ex $ loc_write r cv_regval ] in if RT.is_writeable r then C.StaticInline C.Void name args body else C.Comment $ printf "Register %s is not writeable" (RT.name r) -- -- Get the arguments right for array- and non-array registers -- register_arg_list :: [C.Param] -> RT.Rec -> [C.Param] -> [C.Param] register_arg_list pre r post = (pre ++ [ C.Param (C.Ptr device_c_type) cv_dev ] ++ (if RT.is_array r then [ C.Param (C.TypeName "int") cv_i ] else [] ) ++ post) register_callarg_list :: [C.Param] -> RT.Rec -> [C.Param] -> [C.Param] register_callarg_list pre r post = (pre ++ [ C.Param (C.Ptr device_c_type) cv_dev ] ++ (if RT.is_array r then [ C.Param (C.TypeName "int") cv_i ] else [] ) ++ post) -- -- Generate an expression for a read or write of a register, -- regardless of address space or whether it's an array or not. -- loc_read :: RT.Rec -> C.Expr loc_read r = case RT.spc r of Space.NoSpace -> C.Call (register_rawread_fn_name r) [ C.Variable cv_dev ] Space.Builtin { Space.n = name } -> C.Call (mackerel_read_fn_name name (RT.size r)) [ C.DerefField (C.Variable cv_dev) (RT.base r), loc_array_offset r ] s@Space.Defined { Space.t = Space.REGISTERWISE } -> C.Call (space_cpu_reg_read_fn_name s (RT.size r) (RT.base r)) [ ] s@Space.Defined {} -> C.Call (space_read_fn_name s (RT.size r)) [ C.Variable cv_dev, loc_array_offset r ] loc_read_decl :: RT.Rec -> C.TypeSpec -> [ C.Param ] -> C.Unit loc_read_decl r tpe args = case RT.spc r of -- s@Space.Defined { Space.t = Space.REGISTERWISE } -> -- C.FunctionDecl tpe (space_cpu_reg_read_fn_name s (RT.size r) (RT.base r)) (tail args) _ -> C.NoOp loc_write_decl :: RT.Rec -> C.TypeSpec -> [ C.Param ] -> C.Unit loc_write_decl r tpe args = case RT.spc r of -- s@Space.Defined { Space.t = Space.REGISTERWISE } -> -- C.FunctionDecl C.Void (space_cpu_reg_write_fn_name s (RT.size r) (RT.base r)) -- (tail args) _ -> C.NoOp loc_write :: RT.Rec -> String -> C.Expr loc_write r val = case RT.spc r of Space.NoSpace -> C.Call (register_rawwrite_fn_name r) [ C.Variable cv_dev, C.Variable val ] Space.Builtin { Space.n = name } -> C.Call (mackerel_write_fn_name name (RT.size r)) [ C.DerefField (C.Variable cv_dev) (RT.base r), loc_array_offset r, C.Variable val ] s@Space.Defined { Space.t = Space.REGISTERWISE} -> C.Call (space_cpu_reg_write_fn_name s (RT.size r) (RT.base r)) [ C.Variable val ] s@Space.Defined {} -> C.Call (space_write_fn_name s (RT.size r)) [ C.Variable cv_dev, loc_array_offset r, C.Variable val ] -- -- Calculate the C expression for an appropriate offset for a register -- array element, taking into account whether the address space is -- Bytewise or Valuewise, and whether the array is a list or a step -- format. -- -- XXX List locations are not well handled right now! -- loc_array_offset :: RT.Rec -> C.Expr loc_array_offset r = case (Space.t $ RT.spc r, RT.offset r, RT.arr r, RT.size r) of (_, off, ArrayListLoc [], _) -> C.HexConstant off (Space.VALUEWISE, off, ArrayStepLoc _ 0, _) -> C.Binary C.Plus (C.HexConstant off) (C.Variable cv_i) (Space.BYTEWISE s, off, ArrayStepLoc _ 0, sz) -> C.Binary C.Plus (C.HexConstant off) (C.Binary C.Times (C.Variable cv_i) (C.Binary C.Divide (C.NumConstant (sz `div` s)) (C.NumConstant 8))) (_, off, ArrayStepLoc _ step, _) -> C.Binary C.Plus (C.HexConstant off) (C.Binary C.Times (C.Variable cv_i) (C.NumConstant step)) (_, _, ArrayListLoc locations, _) -> C.StringConstant $ show locations -- Like here for instance. -- -- Emit a function to extract a field from a register type value -- register_read_field_fn :: RT.Rec -> Fields.Rec -> C.Unit register_read_field_fn r f = C.StaticInline (field_c_type f) name args body where args = register_arg_list [] r [] name = register_read_field_fn_name r f extr = regtype_extract_fn_name (RT.tpe r) f body = [ register_print_init r, C.Return $ C.Call extr [ C.Variable cv_regval ] ] -- -- Emit a function to extract a field from a register type value -- register_read_field_from_shadow_fn :: RT.Rec -> Fields.Rec -> C.Unit register_read_field_from_shadow_fn r f = C.StaticInline (field_c_type f) name args body where args = register_arg_list [] r [] name = register_read_field_from_shadow_fn_name r f extr = regtype_extract_fn_name (RT.tpe r) f body = [ C.Return $ C.Call extr [ register_shadow_ref r ] ] -- -- Writing a field of a register is complicated. We need: -- 0) An initial value consisting of the field value masked/shifted into place -- 1) A mask of all field values to read from the register. -- 2) A mask of all field values to read from the shadow. -- 3) A mask of all field values which must be zeroed. -- 4) A mask of all field values which must be one. register_write_field_fn :: RT.Rec -> Fields.Rec -> C.Unit register_write_field_fn r f = C.StaticInline C.Void name args body where args = register_arg_list [] r [ C.Param (field_c_type f) cv_fieldval ] name = register_write_field_fn_name r f fl = delete f $ RT.fl r size = RT.size r rtn = regtype_c_type $ RT.tpe r nomask = 0xffffffffffffffff prsvmask :: Integer prsvmask = foldl (.|.) 0 [ Fields.extract_mask f' size | f' <- fl, (attr_can_init_from_reg $ Fields.attr f') ] shadmask :: Integer shadmask = foldl (.|.) 0 [ Fields.extract_mask f' size | f' <- fl, (attr_is_writeonly $ Fields.attr f') ] mb0mask :: Integer mb0mask = foldl (.&.) nomask [ Fields.insert_mask f' size | f' <- fl, attr_zero_before_write $ Fields.attr f' ] mb1mask :: Integer mb1mask = foldl (.|.) 0 [ Fields.extract_mask f' size | f' <- fl, attr_set_before_write $ Fields.attr f' ] body = [ C.VarDecl C.NoScope C.NonConst (register_c_type r) cv_regval (Just $ (C.Binary C.BitwiseAnd (C.HexConstant $ Fields.extract_mask f size) (C.Binary C.LeftShift (C.Cast rtn (C.Variable cv_fieldval)) (C.NumConstant $ Fields.offset f)))), (if prsvmask /= 0 then (C.Ex $ C.Assignment (C.Variable cv_regval) (C.Binary C.BitwiseOr (C.Variable cv_regval) (C.Binary C.BitwiseAnd (C.HexConstant prsvmask) (loc_read r)))) else C.SComment "No pre-read of register required" ), (if shadmask /= 0 then (C.Ex $ C.Assignment (C.Variable cv_regval) (C.Binary C.BitwiseOr (C.Variable cv_regval) (C.Binary C.BitwiseAnd (C.HexConstant shadmask) (register_shadow_ref r)))) else C.SComment "No read of register shadow required" ), (if mb0mask /= nomask then (C.Ex $ C.Assignment (C.Variable cv_regval) (C.Binary C.BitwiseAnd (C.Variable cv_regval) (C.HexConstant mb0mask))) else C.SComment "No MB0 fields present" ), (if mb1mask /= 0 then (C.Ex $ C.Assignment (C.Variable cv_regval) (C.Binary C.BitwiseOr (C.Variable cv_regval) (C.HexConstant mb1mask))) else C.SComment "No MB1 fields present" ), C.Ex $ loc_write r cv_regval, (if RT.needs_shadow r then C.Ex $ C.Assignment (register_shadow_ref r) (C.Variable cv_regval) else C.SComment "No shadow register to write to" ) ] -- Print out a value of the register type register_print_fn :: RT.Rec -> [ C.Unit ] register_print_fn r | RT.is_array r = [ register_print_array_element r, register_print_array r ] | otherwise = [ register_print_single r ] register_print_array_element :: RT.Rec -> C.Unit register_print_array_element r = snprintf_like_defn (regarray_print_fn_name r) args body where args = [ C.Param (C.Ptr device_c_type) cv_dev, C.Param (C.TypeName "int") cv_i ] body = [ register_print_init r, snprintf_like_call "snprintf" [ C.StringConstant "Register %s[%d] (%s): ", C.StringConstant $ RT.name r, C.Variable cv_i, C.StringConstant $ RT.desc r ] ] ++ (register_print_value r) register_print_array :: RT.Rec -> C.Unit register_print_array r = snprintf_like_defn (register_print_fn_name r) args body where args = [ C.Param (C.Ptr device_c_type) cv_dev ] body = [ simple_var "int" cv_i Nothing, simple_for (C.NumConstant $ RT.num_elements r) [ snprintf_like_call (regarray_print_fn_name r) [ C.Variable cv_dev, C.Variable cv_i ] ] ] register_print_single :: RT.Rec -> C.Unit register_print_single r = snprintf_like_defn (register_print_fn_name r) args body where args = [ C.Param (C.Ptr device_c_type) cv_dev ] body = [ register_print_init r, snputs_like_call $ printf "Register %s (%s): " (RT.name r) (RT.desc r) ] ++ register_print_value r register_print_value :: RT.Rec -> [ C.Stmt ] register_print_value r = case RT.tpe r of TT.RegFormat {} -> [ snputs_like_call "\n" ] ++ [ field_print_block (RT.tpe r) f | f <- (RT.fl r) ] TT.DataFormat {} -> [ snputs_like_call "\n" ] ++ [ field_print_block (RT.tpe r) f | f <- (RT.fl r) ] TT.Primitive {} -> [ register_print_primitive r ] TT.ConstType {} -> [ register_print_consttype r ] register_print_primitive :: RT.Rec -> C.Stmt register_print_primitive r = let extra = if RT.needs_shadow r then " (SHADOW copy)" else "" fmt = C.StringCat [ C.QStr "\t%", C.NStr $ field_fmt_str $ RT.size r, C.QStr (extra ++ "\n") ] in snprintf_like_call "snprintf" [ fmt, C.Variable cv_regval ] register_print_consttype :: RT.Rec -> C.Stmt register_print_consttype r = let extra = if RT.needs_shadow r then " (SHADOW copy)" else "" c = constants_print_fn_name $ TT.tt_name $ RT.tpe r in snprintf_like_call c [ C.Variable cv_regval ] register_print_init :: RT.Rec -> C.Stmt register_print_init r = C.VarDecl C.NoScope C.NonConst (register_c_type r) cv_regval (Just expr) where expr = if RT.is_readable r then loc_read r else register_shadow_ref r