1{- 2 ShiftDriver: Mackerel backend for device drivers 3 4 Part of Mackerel: a strawman device definition DSL for Barrelfish 5 6 Copyright (c) 2007, 2008, 2010, ETH Zurich. 7 All rights reserved. 8 9 This file is distributed under the terms in the attached LICENSE file. 10 If you do not find this file, copies can be found by writing to: 11 ETH Zurich D-INFK, Haldeneggsteig 4, CH-8092 Zurich. Attn: Systems Group. 12-} 13 14module ShiftDriver where 15 16import System.IO 17import System.Exit 18import Data.List 19import Data.Bits 20import Text.Printf 21import MackerelParser 22import Checks 23 24import Attr 25import qualified Space 26import qualified CAbsSyntax as C 27import qualified TypeName as TN 28import qualified TypeTable as TT 29import qualified RegisterTable as RT 30import qualified Fields 31import qualified Dev 32 33------------------------------------------------------------------------ 34-- Standardized names of C variables 35------------------------------------------------------------------------ 36cv_i = "_i" -- Index for register arrays 37cv_dev = "_dev" -- Device structure 38cv_avail = "_avail" -- Available buffer space for snprintf 39cv_size = "_size" -- Size of buffer for snprintf 40cv_s = "_s" -- Buffer ptr for snprint 41cv_rc = "_rc" -- Return value from snprintf 42cv_r = "_r" -- Accumulator for snprintf values 43cv_regval = "_regval" -- Value of type register contents 44cv_fieldval = "_fieldval" -- Value of type field contents 45cv_dtptr = "_dtptr" -- Value of type pointer to datatype struct 46cv_e = "_e" -- Enumeration type value 47 48------------------------------------------------------------------------- 49-- The C Language mapping: top level name definitions 50------------------------------------------------------------------------- 51 52-- 53-- Device-related names 54-- 55 56device_c_name :: String 57device_c_name = "__DN(t)" 58 59device_shadow_field_name :: RT.Rec -> String 60device_shadow_field_name rt = (RT.name rt) ++ "_shadow" 61 62device_initialize_fn_name :: Dev.Rec -> String 63device_initialize_fn_name d = qual_devname d [ "initialize" ] 64 65device_print_fn_name :: Dev.Rec -> String 66device_print_fn_name d = qual_devname d [ "pr" ] 67 68device_prefix_macro_name :: Dev.Rec -> String 69device_prefix_macro_name d = qual_devname d ["PREFIX"] 70 71device_initial_enum_name :: Dev.Rec -> String 72device_initial_enum_name d = qual_devname d ["initials"] 73 74-- 75-- Space-related names 76-- 77space_read_fn_name :: Space.Rec -> Integer -> String 78space_read_fn_name s w = 79 printf "__DN(%s)" (concat $ intersperse "_" [ Space.n s, "read", show w ]) 80 81space_write_fn_name :: Space.Rec -> Integer -> String 82space_write_fn_name s w = 83 printf "__DN(%s)" (concat $ intersperse "_" [ Space.n s, "write", show w ]) 84 85space_cpu_reg_read_fn_name :: Space.Rec -> Integer -> String -> String 86space_cpu_reg_read_fn_name s w n = 87 printf (concat $ intersperse "_" [ Space.n s, "read", show w, n ]) 88 89space_cpu_reg_write_fn_name :: Space.Rec -> Integer -> String -> String 90space_cpu_reg_write_fn_name s w n = 91 printf (concat $ intersperse "_" [ Space.n s, "write", show w, n ]) 92 93-- 94-- Constants-related names 95-- 96constants_c_name :: TT.Rec -> String 97constants_c_name c = qual_typerec c ["t"] 98 99constants_elem_c_name :: TT.Val -> String 100constants_elem_c_name v = qual_device (TT.ctype v) [ TT.cname v ] 101 102constants_print_fn_name :: TN.Name -> String 103constants_print_fn_name c = qual_typename c ["prtval"] 104 105constants_describe_fn_name :: TT.Rec -> String 106constants_describe_fn_name c = qual_typerec c ["describe" ] 107 108-- 109-- Register and datatype-related names 110-- 111regtype_c_name :: TT.Rec -> String 112regtype_c_name rt 113 | TT.is_builtin rt = (TN.typeName $ TT.tt_name rt) ++ "_t" 114 | otherwise = qual_typerec rt ["t"] 115 116regtype_initial_macro_name :: TT.Rec -> String 117regtype_initial_macro_name rt = qual_typerec rt ["default"] 118 119regtype_extract_fn_name :: TT.Rec -> Fields.Rec -> String 120regtype_extract_fn_name rt f = qual_typerec rt [ Fields.name f, "extract" ] 121 122regtype_insert_fn_name :: TT.Rec -> Fields.Rec -> String 123regtype_insert_fn_name rt f = qual_typerec rt [ Fields.name f, "insert" ] 124 125regtype_print_fn_name :: TT.Rec -> String 126regtype_print_fn_name rt = qual_typerec rt [ "prtval"] 127 128datatype_array_c_name :: TT.Rec -> String 129datatype_array_c_name rt = qual_typerec rt [ "array", "t"] 130 131datatype_size_macro_name :: TT.Rec -> String 132datatype_size_macro_name rt = qual_typerec rt ["size"] 133 134-- 135-- Register- and register array-related names 136-- 137register_initial_name :: RT.Rec -> String 138register_initial_name r = qual_register r [ "initial" ] 139 140register_read_fn_name :: RT.Rec -> String 141register_read_fn_name r = qual_register r ["rd"] 142 143register_write_fn_name :: RT.Rec -> String 144register_write_fn_name r = qual_register r ["wr"] 145 146register_rawread_fn_name :: RT.Rec -> String 147register_rawread_fn_name r = qual_register r ["rawrd"] 148 149register_rawwrite_fn_name :: RT.Rec -> String 150register_rawwrite_fn_name r = qual_register r ["rawwr"] 151 152register_shadow_name :: RT.Rec -> String 153register_shadow_name r = qual_register r ["shadow"] 154 155register_c_name :: RT.Rec -> String 156register_c_name r = regtype_c_name $ RT.tpe r 157 158field_c_name :: Fields.Rec -> String 159field_c_name f = 160 case Fields.tpe f of 161 Nothing -> round_field_size $ Fields.size f 162 Just t -> qual_typename t ["t"] 163 164register_print_fn_name :: RT.Rec -> String 165register_print_fn_name rt = qual_register rt ["pr"] 166 167register_read_field_fn_name :: RT.Rec -> Fields.Rec -> String 168register_read_field_fn_name r f = qual_register r [ Fields.name f, "rdf"] 169 170register_read_field_from_shadow_fn_name :: RT.Rec -> Fields.Rec -> String 171register_read_field_from_shadow_fn_name r f = 172 qual_register r [Fields.name f, "rd", "shadow"] 173 174register_write_field_fn_name :: RT.Rec -> Fields.Rec -> String 175register_write_field_fn_name r f = qual_register r [ Fields.name f, "wrf"] 176 177regarray_length_macro_name :: RT.Rec -> String 178regarray_length_macro_name r = qual_register r [ "length" ] 179 180regarray_print_fn_name :: RT.Rec -> String 181regarray_print_fn_name rt = qual_register rt ["pri"] 182 183------------------------------------------------------------------------- 184-- Convenience functions for generating the C mapping 185------------------------------------------------------------------------- 186 187-- 188-- Given a field width in bits, return the C type of the smallest 189-- possible unsigned integer capable of holding it. 190-- 191round_field_size w 192 | w <= 8 = "uint8_t" 193 | ( w > 8 && w <= 16 ) = "uint16_t" 194 | ( w > 16 && w <= 32 ) = "uint32_t" 195 | otherwise = "uint64_t" 196 197-- 198-- Take a list of scope names and translate to a C identifier. 199-- 200 201qual_devname :: Dev.Rec -> [ String ] -> String 202qual_devname d l = 203 concat $ intersperse "_" ([Dev.name d] ++ l) 204 205qual_device :: TN.Name -> [ String ] -> String 206qual_device t l = 207 concat $ intersperse "_" ([TN.devName t] ++ l) 208 209qual_typename :: TN.Name -> [ String ] -> String 210qual_typename (TN.Name dn tn) l = concat $ intersperse "_" ([dn, tn] ++ l) 211 212qual_typerec :: TT.Rec -> [ String ] -> String 213qual_typerec t l = qual_typename (TT.tt_name t) l 214 215qual_register :: RT.Rec -> [ String ] -> String 216qual_register r l = qual_device (RT.typename r) ([RT.name r] ++ l) 217 218-- 219-- Generate a simple automatic variable declaration with optional initializer. 220-- 221simple_var :: String -> String -> Maybe C.Expr -> C.Stmt 222simple_var t n e 223 = C.VarDecl C.NoScope C.NonConst (C.TypeName t) n e 224 225-- 226-- Generate a simple for loop with i = 0 to something. 227-- 228simple_for :: C.Expr -> [ C.Stmt ] -> C.Stmt 229simple_for end body 230 = C.For (C.Assignment (C.Variable cv_i) (C.NumConstant 0)) 231 (C.Binary C.LessThan (C.Variable cv_i) end) 232 (C.PostInc (C.Variable cv_i)) 233 body 234 235-- 236-- Given a field width in bits, return the C snprintf format 237-- specifying to correctly format it. 238-- 239field_fmt_str size 240 | size <= 8 = "PRIx8" 241 | size <= 16 = "PRIx16" 242 | size <= 32 = "PRIx32" 243 | otherwise = "PRIx64" 244 245-- 246-- Percent-escape a string so it can be used in a format to snprintf. 247-- 248percent_escape :: String -> String 249percent_escape s 250 = concat [ if c == '%' then "%%" else [c] | c <- s ] 251 252 253-- 254-- Define a static inline function which looks like an snprintf in its 255-- calling conventions, and maintains its internal buffer variables 256-- accordingly. 257-- 258snprintf_like_defn :: String -> [ C.Param ] -> [ C.Stmt ] -> C.Unit 259snprintf_like_defn name extra_args main_body = 260 C.StaticInline (C.TypeName "int") name args body 261 where args = [ C.Param (C.Ptr $ C.TypeName "char") cv_s, 262 C.Param (C.TypeName "size_t") cv_size ] ++ extra_args 263 body = [ simple_var "int" cv_r (Just $ C.NumConstant 0), 264 simple_var "int" cv_avail Nothing, 265 simple_var "int" cv_rc Nothing ] 266 ++ 267 main_body 268 ++ 269 [ C.Return $ C.Variable cv_r ] 270 271-- 272-- Wrap a call to a function which acts like snprintf (i.e. takes a 273-- buffer, and a size, and tries to fit the output into the buffer). 274-- The code generated here can be safely nested inside another 275-- snprintf-like function as long as the variable names 'avail', 276-- 'size', 'r', and 'rc' are declared. 277-- 278snprintf_like_call :: String -> [C.Expr] -> C.Stmt 279snprintf_like_call n a = 280 C.StmtList [ C.Ex $ C.Assignment (C.Variable cv_avail) $ 281 C.Ternary 282 (C.Binary C.GreaterThan 283 (C.Variable cv_r) 284 (C.Variable cv_size)) 285 (C.NumConstant 0) 286 (C.Binary C.Minus 287 (C.Variable cv_size) 288 (C.Variable cv_r)), 289 C.Ex $ C.Assignment 290 (C.Variable cv_rc) 291 (C.Call n ([ C.Binary C.Plus 292 (C.Variable cv_s) 293 (C.Variable cv_r), 294 C.Variable cv_avail 295 ] ++ a)), 296 C.If 297 (C.Binary C.And 298 (C.Binary C.GreaterThan 299 (C.Variable cv_rc) 300 (C.NumConstant 0)) 301 (C.Binary C.LessThan 302 (C.Variable cv_rc) 303 (C.Variable cv_avail))) 304 [ C.Ex $ C.Assignment (C.Variable cv_r) 305 (C.Binary C.Plus 306 (C.Variable cv_r) 307 (C.Variable cv_rc)) ] 308 [] 309 ] 310 311snputs_like_call :: String -> C.Stmt 312snputs_like_call s = snprintf_like_call "snprintf" [ C.StringConstant $ percent_escape s ] 313 314-- 315-- Functions to generate masks to select or deselect a subfield of bits 316-- 317select_mask :: (Num a, Bits a) => Integer -> Integer -> Integer -> a 318select_mask word_size start width = 319 foldl setBit 0 (enumFromTo (fromInteger $ start) 320 (fromInteger $ start + width - 1)) 321 322deselect_mask :: (Num a, Bits a) => Integer -> Integer -> Integer -> a 323deselect_mask word_size start width = 324 foldl complementBit (select_mask word_size start width) 325 (enumFromTo 0 (fromInteger word_size - 1)) 326 327-- 328-- Functions to generate the builtin Mackerel access functions 329-- 330mackerel_read_fn_name :: String -> Integer -> String 331mackerel_read_fn_name typename size = 332 printf "mackerel_read_%s_%s" typename (show size) 333 334mackerel_write_fn_name :: String -> Integer -> String 335mackerel_write_fn_name typename size = 336 printf "mackerel_write_%s_%s" typename (show size) 337 338 339-- 340-- Generate a string describing a register field 341-- 342field_dump :: Fields.Rec -> String 343field_dump f 344 = printf " %s\t(size %d, offset %d, init %x):\t%s\t%s" 345 (Fields.name f) 346 (Fields.size f) 347 (Fields.offset f) 348 (Fields.initial f) 349 (show $ Fields.attr f) 350 (Fields.desc f ) 351 352-- translation function mapped to every argument, for generic conversion 353-- (eg. types or names) before rendering those arguments in C code 354 355convert_arg (Arg "addr" x) = Arg "mackerel_addr_t" x 356convert_arg (Arg "pci" x) = Arg "mackerel_pci_t" x 357convert_arg (Arg "io" x) = Arg "mackerel_io_t" x 358 359 360------------------------------------------------------------------------- 361-- Top-level header file rendering code 362------------------------------------------------------------------------- 363 364-- Top-level create-a-header-file 365compile :: String -> String -> Dev.Rec -> String 366compile infile outfile dev = 367 unlines $ C.pp_unit $ device_header_file dev infile 368 369device_header_file_string :: Dev.Rec -> String -> String 370device_header_file_string d hdr 371 = unlines $ C.pp_unit $ device_header_file d hdr 372 373device_header_file :: Dev.Rec -> String -> C.Unit 374device_header_file d hdr = 375 let sym = "__" ++ (Dev.name d) ++ "_DEV_H" 376 in 377 C.IfNDef sym ([ C.Define sym [] "1"] ++ (device_def d hdr)) [] 378 379-- Body of the generated file 380device_def :: Dev.Rec -> String -> [ C.Unit ] 381device_def dev header = 382 ( [device_preamble dev] 383 ++ 384 std_header_files dev 385 ++ 386 device_prefix_defs dev 387 ++ 388 concat [ constants_decl d 389 | d@(TT.ConstType {}) <- Dev.types dev] 390 ++ 391 concat [ regtype_decl d 392 | d@(TT.RegFormat {}) <- Dev.types dev ] 393 ++ 394 concat [ datatype_decl d 395 | d@(TT.DataFormat {}) <- Dev.types dev] 396 ++ 397 (device_struct_def dev) 398 ++ 399 (device_initial_values dev) 400 ++ 401 (device_initialize_fn dev) 402 ++ 403 -- Not currently implemented in command line opts 404 -- (device_space_includes dev header) 405 -- ++ 406 concat [ register_decl d | d <- (Dev.registers dev) ] 407 ++ 408 [(device_print_fn dev)] 409 ++ 410 (device_prefix_undefs dev) 411 ) 412 413device_preamble :: Dev.Rec -> C.Unit 414device_preamble dev = 415 C.MultiComment [ 416 "DEVICE DEFINITION: " ++ (Dev.desc dev), 417 "", 418 "Copyright (c) 2010, ETH Zurich.", 419 "All rights reserved.", 420 "", 421 "This file is distributed under the terms in the attached LICENSE", 422 "file. If you do not find this file, copies can be found by", 423 "writing to:", 424 "ETH Zurich D-INFK, Universitaetstr. 6, CH-8092 Zurich.", 425 "Attn: Systems Group.", 426 "", 427 "THIS FILE IS AUTOMATICALLY GENERATED BY MACKEREL: DO NOT EDIT!" ] 428 429device_c_type :: C.TypeSpec 430device_c_type = C.TypeName device_c_name 431 432-- Undefine macros used by the header file 433device_prefix_undefs :: Dev.Rec -> [ C.Unit ] 434device_prefix_undefs d = [ C.Undef "__DN" ] 435 436-- Define macros used by the header file 437device_prefix_defs :: Dev.Rec -> [ C.Unit ] 438device_prefix_defs d = 439 let name = Dev.name d 440 prefix = device_prefix_macro_name d 441 in 442 (device_prefix_undefs d) 443 ++ 444 [ C.Define "__DN" ["x"] (name ++ " ## _ ## x") ] 445 446-- Header files info 447std_header_files :: Dev.Rec -> [ C.Unit ] 448std_header_files dev = 449 map (C.Include C.Standard) inclist 450 where 451 inclist = [ "mackerel/mackerel.h", "inttypes.h" ] 452 ++ 453 [ i ++ "_dev.h" | i <- Dev.imports dev ] 454 455-- Device representation structure generator 456device_struct_def :: Dev.Rec -> [ C.Unit ] 457device_struct_def d 458 = [ C.MultiComment ["Device representation structure"], 459 C.StructDecl device_c_name params, 460 C.TypeDef (C.Struct device_c_name) device_c_name ] 461 where 462 params = [ C.Param (C.TypeName n) v 463 | Arg n v <- map convert_arg (Dev.args d) ] 464 ++ 465 [ device_struct_shadow_field r 466 | r <- RT.get_shadow_registers $ Dev.registers d ] 467 468device_struct_shadow_field :: RT.Rec -> C.Param 469device_struct_shadow_field rt = 470 let t = if RT.is_array rt then 471 C.Array (RT.num_elements rt) (regtype_c_type $ RT.tpe rt) 472 else 473 regtype_c_type $ RT.tpe rt 474 in 475 C.Param t (device_shadow_field_name rt) 476 477device_initial_values :: Dev.Rec -> [ C.Unit ] 478device_initial_values d@( Dev.Rec{ Dev.registers = [] } ) 479 = [ C.Blank, C.Comment "No registers in this device", C.Blank ] 480device_initial_values d 481 = [ C.Blank, 482 C.MultiComment ["Initial register values (currently 0)"], 483 C.EnumDecl (device_initial_enum_name d) 484 [ C.EnumItem (register_initial_name r) (Just $ C.HexConstant $ 0) 485 | r <- (Dev.registers d) ], 486 C.Blank ] 487 488device_initialize_field :: RT.Rec -> C.Stmt 489device_initialize_field rt 490 = let val = C.Variable $ register_initial_name rt 491 in 492 if RT.is_array rt then 493 C.Block [ simple_var "int" cv_i Nothing, 494 simple_for (C.NumConstant $ RT.num_elements rt) 495 [ C.Ex $ C.Assignment 496 (regarray_shadow_ref rt) 497 val 498 ] 499 ] 500 else 501 C.Ex $ C.Assignment (register_shadow_ref rt) val 502 503device_initialize_arg :: String -> C.Stmt 504device_initialize_arg v 505 = C.Ex $ C.Assignment (C.DerefField (C.Variable cv_dev) v) (C.Variable v) 506 507-- Device init function 508device_initialize_fn :: Dev.Rec -> [ C.Unit ] 509device_initialize_fn d = 510 [ C.MultiComment [ "Device Initialization function" ], 511 C.StaticInline C.Void (device_initialize_fn_name d) params body ] 512 where 513 args = Dev.args d 514 params = [ C.Param (C.Ptr device_c_type) cv_dev ] 515 ++ 516 [ C.Param (C.TypeName n) v 517 | (Arg n v) <- map convert_arg args ] 518 body = [ device_initialize_arg v | (Arg _ v) <- args ] 519 -- XXX: Shadow copy initialization broken 520 -- ++ 521 -- [ device_initialize_field rt 522 -- | rt <- RT.get_shadow_registers $ Dev.registers d ] 523 524device_print_fn :: Dev.Rec -> C.Unit 525device_print_fn d = 526 snprintf_like_defn (device_print_fn_name d) args body 527 where args = [ C.Param (C.Ptr device_c_type) cv_dev ] 528 body = [ snputs_like_call "-------------------------\n", 529 snputs_like_call (printf "Dump of device %s (%s):\n" 530 (Dev.name d) (percent_escape (Dev.desc d))) 531 ] 532 ++ 533 [ device_print_eachreg r | r <- (Dev.registers d)] 534 ++ 535 [ snputs_like_call (printf "End of dump of device %s\n" 536 (Dev.name d) ), 537 snputs_like_call "-------------------------\n" 538 ] 539 540device_print_eachreg r = 541 snprintf_like_call (register_print_fn_name r) [ C.Variable cv_dev ] 542 543-- XXX: This needs more thorough examination. I don't know how the 544-- commandline is interacting with device spaces. Currently, when 545-- there are no device spaces defined, the commandline is ignored. 546device_space_includes :: Dev.Rec -> String -> [ C.Unit ] 547device_space_includes d header 548 | all Space.is_builtin (Dev.spaces d) = 549 [ C.MultiComment [ "No user-defined spaces" ] ] 550 | header /= "" = 551 [ C.MultiComment [ "Space access include overridden by cmd line:"], 552 C.Include C.Local header ] 553 | otherwise = 554 [ C.MultiComment [ "Include access functions for user-defined spaces"], 555 C.Include C.Local $ printf "%s_spaces.h" (Dev.name d) ] 556 557------------------------------------------------------------------------- 558-- Render 'constants' declarations 559------------------------------------------------------------------------- 560 561-- 562-- Everything we need for a constants definition 563-- 564 565constants_decl :: TT.Rec -> [ C.Unit ] 566constants_decl c = 567 [ constants_comment c, 568 constants_typedef c ] ++ 569 ( constants_enum c ) ++ 570 [ C.Blank, 571 constants_describe_fn c, 572 constants_print_fn c ] 573 574constants_c_type :: TT.Rec -> C.TypeSpec 575constants_c_type c = C.TypeName $ constants_c_name c 576 577constants_comment :: TT.Rec -> C.Unit 578constants_comment c = 579 C.MultiComment [ printf "Constants defn: %s (%s)" (TN.toString $ TT.tt_name c) (TT.tt_desc c), 580 case TT.tt_width c of 581 Nothing -> " - no width specified" 582 Just w -> printf " - width %d bits" w ] 583 584constants_enum :: TT.Rec -> [ C.Unit ] 585constants_enum c = 586 [ C.Define (constants_elem_c_name v) [] (constants_eval c v) | v <- TT.tt_vals c ] 587 588constants_typedef :: TT.Rec -> C.Unit 589constants_typedef c = 590 C.TypeDef (C.TypeName $ round_field_size $ TT.tt_size c) (constants_c_name c) 591 592constants_eval :: TT.Rec -> TT.Val -> String 593constants_eval c v = 594 printf "((%s)%s)" (constants_c_name c) (case TT.cval v of 595 ExprConstant (-1) -> "(-1LL)" 596 ExprConstant i -> printf "0x%x" i 597 ) 598 599constants_print_fn :: TT.Rec -> C.Unit 600constants_print_fn c = 601 C.StaticInline (C.TypeName "int") (constants_print_fn_name $ TT.tt_name c) 602 [ C.Param (C.Ptr $ C.TypeName "char") cv_s, 603 C.Param (C.TypeName "size_t") cv_size, 604 C.Param (constants_c_type c) cv_e ] 605 [ C.VarDecl C.NoScope C.NonConst (C.Ptr $ C.TypeName "char") "d" 606 (Just $ C.Call (constants_describe_fn_name c) [ C.Variable cv_e ]), 607 C.If (C.Variable "d") 608 [ C.Return $ C.Call "snprintf" 609 [ C.Variable cv_s, 610 C.Variable cv_size, 611 C.StringConstant "%s", 612 C.Variable "d" 613 ] 614 ] 615 [ C.Return $ C.Call "snprintf" 616 [ C.Variable cv_s, 617 C.Variable cv_size, 618 C.StringCat [ C.QStr "Unknown constant %s value 0x%", 619 C.NStr "PRIx64" ], 620 C.StringConstant (constants_c_name c), 621 C.Cast (C.TypeName "uint64_t") (C.Variable cv_e) 622 ] 623 ] 624 ] 625 626constants_describe_fn :: TT.Rec -> C.Unit 627constants_describe_fn c = 628 let 629 rep v = C.StringConstant $ printf "%s: %s" (TT.cname v) (TT.cdesc v) 630 in 631 C.StaticInline (C.Ptr $ C.TypeName "char") (constants_describe_fn_name c) 632 [ C.Param (constants_c_type c) cv_e ] 633 [ C.Switch (C.Variable cv_e) 634 [ C.Case (C.Variable $ constants_elem_c_name v) 635 [ C.Return $ rep v ] 636 | v <- TT.tt_vals c ] 637 [ C.Return $ C.Variable "NULL" ] 638 ] 639 640 641------------------------------------------------------------------------- 642-- Render register type definitions 643------------------------------------------------------------------------- 644 645regtype_c_type :: TT.Rec -> C.TypeSpec 646regtype_c_type rt = C.TypeName $ regtype_c_name rt 647 648-- 649-- All the generated declarations for a register type. 650-- 651regtype_decl :: TT.Rec -> [ C.Unit ] 652regtype_decl rt = 653 [ regtype_dump rt, 654 regtype_typedef rt, 655 regtype_initial_macro rt 656 ] 657 ++ 658 (regtype_access_fns rt) 659 ++ 660 [ 661 regtype_print_fn rt 662 ] 663 664 665-- 666-- Emit a comment describing the register type. 667-- 668regtype_dump :: TT.Rec -> C.Unit 669regtype_dump rt = 670 C.MultiComment ([ (TT.type_kind rt) ++ " type: " ++ (regtype_c_name rt), 671 "Description: " ++ (TT.tt_desc rt), 672 "Fields:" 673 ] 674 ++ 675 [ field_dump f | f <- TT.fields rt ]) 676-- 677-- Calculate an appropriate built-in type for a mackerel type 678-- 679regtype_c_builtin :: TT.Rec -> C.TypeSpec 680regtype_c_builtin rt = C.TypeName $ round_field_size $ TT.tt_size rt 681 682-- 683-- Define the register type to be an unsigned integer of appropriate size 684-- 685regtype_typedef :: TT.Rec -> C.Unit 686regtype_typedef rt = 687 C.TypeDef 688 (regtype_c_builtin rt) 689 (regtype_c_name rt) 690 691-- 692-- Emit macro for initial register value 693-- 694 695regtype_initial_macro :: TT.Rec -> C.Unit 696regtype_initial_macro rt = 697 C.Define sym [] (C.pp_expr $ C.HexConstant val) 698 where 699 sym = regtype_initial_macro_name rt 700 fields = TT.fields rt 701 val = foldl (.|.) 0 [ Fields.initial_mask f | f <- fields ] 702 703-- 704-- Emit functions to extract and insert each field from a value of 705-- register contents. 706-- 707regtype_access_fns :: TT.Rec -> [ C.Unit ] 708regtype_access_fns rt = 709 concat [ [ regtype_field_extract_fn rt f, 710 regtype_field_insert_fn rt f ] 711 | f <- TT.fields rt, not $ Fields.is_anon f ] 712 713-- 714-- Return the C type name for a field or a register 715-- 716 717field_c_type :: Fields.Rec -> C.TypeSpec 718field_c_type f = C.TypeName $ field_c_name f 719 720-- 721-- Emit a function to extract a field from a register type value 722-- 723 724regtype_field_extract_fn :: TT.Rec -> Fields.Rec -> C.Unit 725regtype_field_extract_fn rt f = 726 let t = field_c_type f 727 n = regtype_extract_fn_name rt f 728 sz = TT.tt_size rt 729 arg = C.Param (regtype_c_type rt) cv_regval 730 -- ( r & (Fields.extract_mask f) ) >> (Fields.extract_shift f) 731 body = C.Return $ 732 C.Cast t (C.Binary C.RightShift 733 (C.Binary C.BitwiseAnd 734 (C.Variable cv_regval) 735 (C.HexConstant $ Fields.extract_mask f sz)) 736 (C.NumConstant $ Fields.offset f)) 737 in 738 C.StaticInline t n [ arg ] [ body ] 739 740-- 741-- Emit a function to insert a field value into a register type value 742-- 743regtype_field_insert_fn :: TT.Rec -> Fields.Rec -> C.Unit 744regtype_field_insert_fn rt f = 745 let t = field_c_type f 746 n = regtype_insert_fn_name rt f 747 rtn = regtype_c_type rt 748 sz = TT.tt_size rt 749 arg1 = C.Param rtn cv_regval 750 arg2 = C.Param t cv_fieldval 751 -- return (r & Fields.insert_mask f) | ((rtn)v << (Fields.offset f) & (Fields.insert_mask f)) 752 -- Note that we cast the field type to the register type, to 753 -- ensure that it's large enough when we do the shift 754 body = C.Return $ 755 C.Binary C.BitwiseOr 756 (C.Binary C.BitwiseAnd 757 (C.Variable cv_regval) 758 (C.HexConstant $ Fields.insert_mask f sz) ) 759 (C.Binary C.BitwiseAnd 760 (C.HexConstant $ Fields.extract_mask f sz) 761 (C.Binary C.LeftShift 762 (C.Cast rtn (C.Variable cv_fieldval)) 763 (C.NumConstant $ Fields.offset f))) 764 in 765 C.StaticInline rtn n [ arg1, arg2 ] [ body ] 766 767-- 768-- Print out a value of the register or data type 769-- 770regtype_print_fn :: TT.Rec -> C.Unit 771regtype_print_fn rt = 772 snprintf_like_defn (regtype_print_fn_name rt) args body 773 where 774 fields = TT.fields rt 775 args = [ C.Param (regtype_c_type rt) cv_regval ] 776 body = [ field_print_block rt f | f <- fields, not $ Fields.is_anon f ] 777 778-- 779-- Return a statement (or list) which will correctly format a register 780-- field as part of a larger snprintf-like function. 781-- 782field_print_block :: TT.Rec -> Fields.Rec -> C.Stmt 783field_print_block _ f@(Fields.Rec { Fields.is_anon = True }) = 784 C.SComment ((Fields.name f) ++ " is anonymous") 785field_print_block rt f = 786 case Fields.tpe f of 787 Nothing -> 788 let fmt = C.StringCat [ C.QStr $ printf " %s =\t%%" (Fields.name f), 789 C.NStr (field_fmt_str $ Fields.size f), 790 C.QStr $ printf "\t(%s)\n" (percent_escape $ Fields.desc f) ] 791 val = C.Call (regtype_extract_fn_name rt f) 792 [ C.Variable cv_regval ] 793 in 794 snprintf_like_call "snprintf" [fmt, val] 795 Just t -> 796 C.StmtList [snputs_like_call $ printf " %s =\t" (Fields.name f), 797 snprintf_like_call (constants_print_fn_name t) 798 [ C.Call (regtype_extract_fn_name rt f) [(C.Variable cv_regval)] ], 799 snputs_like_call $ printf "\t(%s)\n" (Fields.desc f) 800 ] 801 802------------------------------------------------------------------------- 803-- Render data type definitions 804------------------------------------------------------------------------- 805 806datatype_decl :: TT.Rec -> [ C.Unit ] 807datatype_decl dt = 808 [ regtype_dump dt, 809 datatype_typedef dt, 810 datatype_array_typedef dt, 811 datatype_size_macro dt 812 ] 813 ++ datatype_access_fns dt 814 ++ [ regtype_print_fn dt ] 815 816 817datatype_typedef :: TT.Rec -> C.Unit 818datatype_typedef dt = 819 C.TypeDef (C.Ptr $ C.TypeName "uint8_t") (regtype_c_name dt) 820 821datatype_array_typedef :: TT.Rec -> C.Unit 822datatype_array_typedef dt = 823 let sz = ((TT.tt_size dt) + 7) `div` 8 824 in 825 C.TypeDef (C.Array sz $ C.TypeName "uint8_t") (datatype_array_c_name dt) 826 827datatype_size_macro :: TT.Rec -> C.Unit 828datatype_size_macro dt = 829 C.GVarDecl C.Static C.Const (C.TypeName "size_t") 830 (datatype_size_macro_name dt) 831 (Just $ C.SizeOfT $ C.TypeName $ datatype_array_c_name dt) 832 833datatype_field_load_size :: Fields.Rec -> Integer 834datatype_field_load_size Fields.Rec {Fields.offset=o, Fields.size=s} 835 | s + (o `mod` 8) <= 8 = 8 836 | s + (o `mod` 16) <= 16 = 16 837 | s + (o `mod` 32) <= 32 = 32 838 | s + (o `mod` 64) <= 64 = 64 839 | otherwise = 0 840 841-- 842-- Emit functions to extract and insert each field from a value of 843-- register contents. 844-- 845datatype_access_fns :: TT.Rec -> [ C.Unit ] 846datatype_access_fns rt = 847 concat [ [ datatype_field_extract_fn rt f, 848 datatype_field_insert_fn rt f ] 849 | f <- TT.fields rt, not $ Fields.is_anon f ] 850 851-- 852-- Emit a function to extract a field from a data type value 853-- 854datatype_field_extract_fn :: TT.Rec -> Fields.Rec -> C.Unit 855datatype_field_extract_fn rt f = 856 let t = field_c_type f 857 n = regtype_extract_fn_name rt f 858 arg = C.Param (regtype_c_type rt) cv_dtptr 859 load_size = datatype_field_load_size f 860 bits_offset = (Fields.offset f) `mod` load_size 861 word_offset = ((Fields.offset f) - bits_offset) `div` 8 862 mask = select_mask load_size bits_offset (Fields.size f) 863 load_c_type = C.TypeName $ round_field_size load_size 864 -- ( r & (Fields.extract_mask f) ) >> (Fields.extract_shift f) 865 body = C.Return $ 866 C.Binary C.RightShift 867 (C.Binary C.BitwiseAnd 868 (C.DerefPtr 869 (C.Cast 870 (C.Ptr load_c_type) 871 (C.Binary C.Plus 872 (C.NumConstant word_offset) 873 (C.Variable cv_dtptr)))) 874 (C.HexConstant $ mask)) 875 (C.NumConstant $ bits_offset) 876 in 877 C.StaticInline t n [ arg ] [ body ] 878 879-- 880-- Emit a function to insert a field value into a data type value 881-- 882datatype_field_insert_fn :: TT.Rec -> Fields.Rec -> C.Unit 883datatype_field_insert_fn rt f = 884 let t = field_c_type f 885 n = regtype_insert_fn_name rt f 886 rtn = C.TypeName $ round_field_size $ TT.wordsize rt 887 arg1 = C.Param (regtype_c_type rt) cv_dtptr 888 arg2 = C.Param t cv_fieldval 889 load_size = datatype_field_load_size f 890 bits_offset = (Fields.offset f) `mod` load_size 891 word_offset = ((Fields.offset f) - bits_offset) `div` 8 892 smask = select_mask load_size bits_offset (Fields.size f) 893 dmask = deselect_mask load_size bits_offset (Fields.size f) 894 load_c_type = C.TypeName $ round_field_size load_size 895 load_expr = (C.DerefPtr 896 (C.Cast 897 (C.Ptr load_c_type) 898 (C.Binary C.Plus 899 (C.NumConstant word_offset) 900 (C.Variable cv_dtptr)))) 901 902 -- return (r & Fields.insert_mask f) | (v << (Fields.offset f) & (Fields.insert_mask f)) 903 body = C.Ex $ 904 C.Assignment load_expr 905 (C.Binary C.BitwiseOr 906 (C.Binary C.BitwiseAnd 907 load_expr 908 (C.HexConstant dmask)) 909 (C.Binary C.BitwiseAnd 910 (C.HexConstant smask) 911 (C.Binary C.LeftShift 912 (C.Variable cv_fieldval) 913 (C.NumConstant bits_offset) 914 )) 915 ) 916 in 917 C.StaticInline C.Void n [ arg1, arg2 ] [ body ] 918 919------------------------------------------------------------------------- 920-- Render register definitions 921------------------------------------------------------------------------- 922 923register_c_type :: RT.Rec -> C.TypeSpec 924register_c_type r = C.TypeName $ register_c_name r 925 926register_shadow_ref :: RT.Rec -> C.Expr 927register_shadow_ref r = 928 let deref = C.DerefField (C.Variable cv_dev) (device_shadow_field_name r) 929 in 930 if RT.is_array r then 931 C.SubscriptOf deref (C.Variable cv_i) 932 else 933 deref 934 935regarray_shadow_ref :: RT.Rec -> C.Expr 936regarray_shadow_ref rt 937 = C.SubscriptOf (register_shadow_ref rt) (C.Variable cv_i) 938 939-- 940-- All the declarations for a given register. Note that all 941-- type-related stuff is handled above here by regtype_*; these 942-- declarations are specific to the register itself. 943-- 944register_decl :: RT.Rec -> [ C.Unit ] 945register_decl r = [ register_dump_comment r, 946 regarray_length_macro r ] 947 ++ 948 ( register_rawread_fn r) 949 ++ 950 [ register_read_fn r ] 951 ++ 952 ( register_rawwrite_fn r) 953 ++ 954 [ 955 register_write_fn r 956 ] 957 ++ 958 ( register_print_fn r) 959 ++ 960 (if not $ TT.is_primitive $ RT.tpe r then 961 [ register_read_field_fn r f 962 | f <- RT.fl r, attr_user_can_read $ Fields.attr f 963 ] 964 ++ 965 [ register_read_field_from_shadow_fn r f 966 | f <- RT.fl r, attr_is_writeonly $ Fields.attr f 967 ] 968 ++ 969 [ register_write_field_fn r f 970 | f <- RT.fl r, attr_user_can_write $ Fields.attr f 971 ] 972 else 973 [] 974 ) 975 976register_dump_comment :: RT.Rec -> C.Unit 977register_dump_comment r 978 = C.MultiComment ([name, typedesc] ++ fields) 979 where title = if (RT.is_array r) then " array" else "" 980 name = printf "Register%s %s: %s" title (RT.name r) (RT.desc r) 981 typedesc = printf "Type: %s (%s)" 982 (TN.toString $ RT.typename r) 983 (if TT.is_primitive $ RT.tpe r 984 then "primitive type" 985 else TT.tt_desc $ RT.tpe r) 986 fields = if TT.is_primitive $ RT.tpe r 987 then [] 988 else [ field_dump f | f <- RT.fl r ] 989 990 991-- 992-- Return a declaration for the length of a register array. 993-- 994regarray_length_macro :: RT.Rec -> C.Unit 995regarray_length_macro r 996 | RT.is_array r = 997 (C.GVarDecl 998 C.Static C.Const (C.TypeName "size_t") 999 (regarray_length_macro_name r) 1000 (Just $ C.NumConstant $ RT.num_elements r)) 1001 | otherwise = C.NoOp 1002 1003-- 1004-- Do a raw read from a register, if the address is available. 1005-- 1006register_rawread_fn :: RT.Rec -> [ C.Unit ] 1007register_rawread_fn r = 1008 let 1009 rtn = regtype_c_type $ RT.tpe r 1010 args = (register_arg_list [] r []) 1011 n = register_rawread_fn_name r 1012 raw_type = regtype_c_builtin $ RT.tpe r 1013 decl = loc_read_decl r raw_type args 1014 in 1015 if RT.is_noaddr r then 1016 [ 1017 C.Comment (printf "%s has no address, user must supply %s" 1018 (RT.name r) n) 1019 ] 1020 else 1021 if RT.is_readable r then 1022 [ 1023 decl, 1024 C.StaticInline rtn n args [ C.Return (loc_read r) ] 1025 ] 1026 else 1027 [ 1028 C.Comment $ printf "Register %s is not readale" (RT.name r) 1029 ] 1030 1031-- 1032-- Read from the register, or from a shadow copy if it's not readable. 1033-- 1034register_read_fn :: RT.Rec -> C.Unit 1035register_read_fn r = 1036 let rtn = regtype_c_type $ RT.tpe r 1037 name = register_read_fn_name r 1038 args = (register_arg_list [] r []) 1039 in 1040 if RT.is_readable r then 1041 C.StaticInline rtn name args [ C.Return (loc_read r) ] 1042 else 1043 C.StaticInline rtn name args [ C.Return (register_shadow_ref r) ] 1044 1045-- 1046-- Do a write read top a register, if the address is available. 1047-- 1048register_rawwrite_fn :: RT.Rec -> [ C.Unit ] 1049register_rawwrite_fn r = 1050 let 1051 rtn = regtype_c_type $ RT.tpe r 1052 args = register_arg_list [] r [ C.Param (regtype_c_type $ RT.tpe r) cv_regval ] 1053 n = register_rawwrite_fn_name r 1054 raw_type = (C.TypeName $ round_field_size $ TT.tt_size $ RT.tpe r) 1055 raw_args = register_arg_list [] r [ C.Param ( regtype_c_builtin $ RT.tpe r) cv_regval ] 1056 decl = loc_write_decl r raw_type raw_args 1057 in 1058 if RT.is_noaddr r then 1059 [ 1060 C.Comment (printf "%s has no address, user must supply %s" 1061 (RT.name r) n) 1062 ] 1063 else 1064 if RT.is_writeable r then 1065 [ 1066 decl, 1067 C.StaticInline C.Void n args [ C.Ex $ loc_write r cv_regval ] 1068 ] 1069 else 1070 [ 1071 C.Comment $ printf "Register %s is not writeable" (RT.name r) 1072 ] 1073 1074 1075-- 1076-- Write to register. Harder than it sounds. 1077-- 1078-- To do this properly involves: 1079 1080-- 1) Take the value to be written 1081-- 2) AND together the MB0 and RSVD fields' insert masks, and AND this with 1082-- the value. 1083-- 3) OR together the MB1 fields' select masks, and OR this with the 1084-- value. 1085-- 4) OR together the RSVD fields' select masks. If this is non-zero, 1086-- AND this mask with a read from the register, and OR this into the value. 1087-- 5) Write this to the register, and to the shadow, if present. 1088-- 1089register_write_fn :: RT.Rec -> C.Unit 1090register_write_fn r = 1091 let name = register_write_fn_name r 1092 args = register_arg_list [] r [ C.Param (regtype_c_type $ RT.tpe r) cv_regval ] 1093 fields = RT.fl r 1094 size = RT.size r 1095 nomask = 0xffffffffffffffff 1096 mb0mask :: Integer 1097 mb0mask = foldl (.&.) nomask [ Fields.insert_mask f size | f <- fields, 1098 (attr_zero_before_write $ Fields.attr f) || 1099 (attr_preserve_on_write $ Fields.attr f) ] 1100 mb1mask :: Integer 1101 mb1mask = foldl (.|.) 0 [ Fields.extract_mask f size | f <- fields, 1102 (attr_set_before_write $ Fields.attr f) ] 1103 prsvmask :: Integer 1104 prsvmask = foldl (.|.) 0 [ Fields.extract_mask f size | f <- fields, 1105 (attr_preserve_on_write $ Fields.attr f) ] 1106 body = [ (if mb0mask /= nomask then 1107 (C.Ex $ C.Assignment 1108 (C.Variable cv_regval) 1109 (C.Binary C.BitwiseAnd 1110 (C.Variable cv_regval) 1111 (C.HexConstant mb0mask))) 1112 else 1113 C.SComment "No MB0 or RSVD fields present" 1114 ), 1115 (if mb1mask /= 0 then 1116 (C.Ex $ C.Assignment 1117 (C.Variable cv_regval) 1118 (C.Binary C.BitwiseOr 1119 (C.Variable cv_regval) 1120 (C.HexConstant mb1mask))) 1121 else 1122 C.SComment "No MB1 fields present" 1123 ), 1124 (if prsvmask /= 0 then 1125 (if RT.is_readable r then 1126 (C.Ex $ C.Assignment 1127 (C.Variable cv_regval) 1128 (C.Binary C.BitwiseOr 1129 (C.Variable cv_regval) 1130 (C.Binary C.BitwiseAnd 1131 (C.HexConstant prsvmask) 1132 (loc_read r)))) 1133 else 1134 C.SComment "No pre-read. Register is write only." 1135 ) 1136 else 1137 C.SComment "No pre-read of register required" 1138 ), 1139 C.Ex $ loc_write r cv_regval 1140 ] 1141 in 1142 if RT.is_writeable r then 1143 C.StaticInline C.Void name args body 1144 else 1145 C.Comment $ printf "Register %s is not writeable" (RT.name r) 1146 1147-- 1148-- Get the arguments right for array- and non-array registers 1149-- 1150register_arg_list :: [C.Param] -> RT.Rec -> [C.Param] -> [C.Param] 1151register_arg_list pre r post 1152 = (pre ++ [ C.Param (C.Ptr device_c_type) cv_dev ] 1153 ++ 1154 (if RT.is_array r then 1155 [ C.Param (C.TypeName "int") cv_i ] 1156 else [] 1157 ) 1158 ++ post) 1159 1160register_callarg_list :: [C.Param] -> RT.Rec -> [C.Param] -> [C.Param] 1161register_callarg_list pre r post 1162 = (pre ++ [ C.Param (C.Ptr device_c_type) cv_dev ] 1163 ++ 1164 (if RT.is_array r then 1165 [ C.Param (C.TypeName "int") cv_i ] 1166 else [] 1167 ) 1168 ++ post) 1169 1170-- 1171-- Generate an expression for a read or write of a register, 1172-- regardless of address space or whether it's an array or not. 1173-- 1174loc_read :: RT.Rec -> C.Expr 1175loc_read r = 1176 case RT.spc r of 1177 Space.NoSpace -> 1178 C.Call (register_rawread_fn_name r) 1179 [ C.Variable cv_dev ] 1180 Space.Builtin { Space.n = name } -> 1181 C.Call (mackerel_read_fn_name name (RT.size r)) 1182 [ C.DerefField (C.Variable cv_dev) (RT.base r), loc_array_offset r ] 1183 s@Space.Defined { Space.t = Space.REGISTERWISE } -> 1184 C.Call (space_cpu_reg_read_fn_name s (RT.size r) (RT.base r)) 1185 [ ] 1186 s@Space.Defined {} -> 1187 C.Call (space_read_fn_name s (RT.size r)) 1188 [ C.Variable cv_dev, loc_array_offset r ] 1189 1190loc_read_decl :: RT.Rec -> C.TypeSpec -> [ C.Param ] -> C.Unit 1191loc_read_decl r tpe args = 1192 case RT.spc r of 1193-- s@Space.Defined { Space.t = Space.REGISTERWISE } -> 1194-- C.FunctionDecl tpe (space_cpu_reg_read_fn_name s (RT.size r) (RT.base r)) (tail args) 1195 _ -> C.NoOp 1196 1197 1198loc_write_decl :: RT.Rec -> C.TypeSpec -> [ C.Param ] -> C.Unit 1199loc_write_decl r tpe args = 1200 case RT.spc r of 1201-- s@Space.Defined { Space.t = Space.REGISTERWISE } -> 1202-- C.FunctionDecl C.Void (space_cpu_reg_write_fn_name s (RT.size r) (RT.base r)) 1203-- (tail args) 1204 _ -> C.NoOp 1205 1206loc_write :: RT.Rec -> String -> C.Expr 1207loc_write r val = 1208 case RT.spc r of 1209 Space.NoSpace -> 1210 C.Call (register_rawwrite_fn_name r) 1211 [ C.Variable cv_dev, C.Variable val ] 1212 Space.Builtin { Space.n = name } -> 1213 C.Call (mackerel_write_fn_name name (RT.size r)) 1214 [ C.DerefField (C.Variable cv_dev) (RT.base r), 1215 loc_array_offset r, 1216 C.Variable val ] 1217 s@Space.Defined { Space.t = Space.REGISTERWISE} -> 1218 C.Call (space_cpu_reg_write_fn_name s (RT.size r) (RT.base r)) 1219 [ C.Variable val ] 1220 s@Space.Defined {} -> 1221 C.Call (space_write_fn_name s (RT.size r)) 1222 [ C.Variable cv_dev, loc_array_offset r, C.Variable val ] 1223 1224-- 1225-- Calculate the C expression for an appropriate offset for a register 1226-- array element, taking into account whether the address space is 1227-- Bytewise or Valuewise, and whether the array is a list or a step 1228-- format. 1229-- 1230-- XXX List locations are not well handled right now! 1231-- 1232loc_array_offset :: RT.Rec -> C.Expr 1233loc_array_offset r 1234 = case (Space.t $ RT.spc r, RT.offset r, RT.arr r, RT.size r) of 1235 (_, off, ArrayListLoc [], _) -> 1236 C.HexConstant off 1237 (Space.VALUEWISE, off, ArrayStepLoc _ 0, _) -> 1238 C.Binary C.Plus (C.HexConstant off) (C.Variable cv_i) 1239 (Space.BYTEWISE s, off, ArrayStepLoc _ 0, sz) -> 1240 C.Binary C.Plus 1241 (C.HexConstant off) 1242 (C.Binary C.Times 1243 (C.Variable cv_i) 1244 (C.Binary C.Divide 1245 (C.NumConstant (sz `div` s)) 1246 (C.NumConstant 8))) 1247 (_, off, ArrayStepLoc _ step, _) -> 1248 C.Binary C.Plus 1249 (C.HexConstant off) 1250 (C.Binary C.Times (C.Variable cv_i) (C.NumConstant step)) 1251 (_, _, ArrayListLoc locations, _) -> 1252 C.StringConstant $ show locations -- Like here for instance. 1253 1254-- 1255-- Emit a function to extract a field from a register type value 1256-- 1257register_read_field_fn :: RT.Rec -> Fields.Rec -> C.Unit 1258register_read_field_fn r f = 1259 C.StaticInline (field_c_type f) name args body 1260 where 1261 args = register_arg_list [] r [] 1262 name = register_read_field_fn_name r f 1263 extr = regtype_extract_fn_name (RT.tpe r) f 1264 body = [ register_print_init r, 1265 C.Return $ C.Call extr [ C.Variable cv_regval ] 1266 ] 1267 1268-- 1269-- Emit a function to extract a field from a register type value 1270-- 1271register_read_field_from_shadow_fn :: RT.Rec -> Fields.Rec -> C.Unit 1272register_read_field_from_shadow_fn r f = 1273 C.StaticInline (field_c_type f) name args body 1274 where 1275 args = register_arg_list [] r [] 1276 name = register_read_field_from_shadow_fn_name r f 1277 extr = regtype_extract_fn_name (RT.tpe r) f 1278 body = [ C.Return $ C.Call extr [ register_shadow_ref r ] ] 1279 1280-- 1281-- Writing a field of a register is complicated. We need: 1282-- 0) An initial value consisting of the field value masked/shifted into place 1283-- 1) A mask of all field values to read from the register. 1284-- 2) A mask of all field values to read from the shadow. 1285-- 3) A mask of all field values which must be zeroed. 1286-- 4) A mask of all field values which must be one. 1287 1288register_write_field_fn :: RT.Rec -> Fields.Rec -> C.Unit 1289register_write_field_fn r f = 1290 C.StaticInline C.Void name args body 1291 where 1292 args = register_arg_list [] r [ C.Param (field_c_type f) cv_fieldval ] 1293 name = register_write_field_fn_name r f 1294 fl = delete f $ RT.fl r 1295 size = RT.size r 1296 rtn = regtype_c_type $ RT.tpe r 1297 nomask = 0xffffffffffffffff 1298 prsvmask :: Integer 1299 prsvmask = foldl (.|.) 0 [ Fields.extract_mask f' size | f' <- fl, 1300 (attr_can_init_from_reg $ Fields.attr f') ] 1301 shadmask :: Integer 1302 shadmask = foldl (.|.) 0 [ Fields.extract_mask f' size | f' <- fl, 1303 (attr_is_writeonly $ Fields.attr f') ] 1304 mb0mask :: Integer 1305 mb0mask = foldl (.&.) nomask [ Fields.insert_mask f' size | f' <- fl, 1306 attr_zero_before_write $ Fields.attr f' ] 1307 mb1mask :: Integer 1308 mb1mask = foldl (.|.) 0 [ Fields.extract_mask f' size | f' <- fl, 1309 attr_set_before_write $ Fields.attr f' ] 1310 body = [ C.VarDecl C.NoScope C.NonConst (register_c_type r) cv_regval 1311 (Just $ (C.Binary C.BitwiseAnd 1312 (C.HexConstant $ Fields.extract_mask f size) 1313 (C.Binary C.LeftShift 1314 (C.Cast rtn (C.Variable cv_fieldval)) 1315 (C.NumConstant $ Fields.offset f)))), 1316 (if prsvmask /= 0 then 1317 (C.Ex $ C.Assignment 1318 (C.Variable cv_regval) 1319 (C.Binary C.BitwiseOr 1320 (C.Variable cv_regval) 1321 (C.Binary C.BitwiseAnd 1322 (C.HexConstant prsvmask) 1323 (loc_read r)))) 1324 else 1325 C.SComment "No pre-read of register required" 1326 ), 1327 (if shadmask /= 0 then 1328 (C.Ex $ C.Assignment 1329 (C.Variable cv_regval) 1330 (C.Binary C.BitwiseOr 1331 (C.Variable cv_regval) 1332 (C.Binary C.BitwiseAnd 1333 (C.HexConstant shadmask) 1334 (register_shadow_ref r)))) 1335 else 1336 C.SComment "No read of register shadow required" 1337 ), 1338 (if mb0mask /= nomask then 1339 (C.Ex $ C.Assignment 1340 (C.Variable cv_regval) 1341 (C.Binary C.BitwiseAnd 1342 (C.Variable cv_regval) 1343 (C.HexConstant mb0mask))) 1344 else 1345 C.SComment "No MB0 fields present" 1346 ), 1347 (if mb1mask /= 0 then 1348 (C.Ex $ C.Assignment 1349 (C.Variable cv_regval) 1350 (C.Binary C.BitwiseOr 1351 (C.Variable cv_regval) 1352 (C.HexConstant mb1mask))) 1353 else 1354 C.SComment "No MB1 fields present" 1355 ), 1356 C.Ex $ loc_write r cv_regval, 1357 (if RT.needs_shadow r then 1358 C.Ex $ C.Assignment 1359 (register_shadow_ref r) 1360 (C.Variable cv_regval) 1361 else 1362 C.SComment "No shadow register to write to" 1363 ) 1364 ] 1365 1366-- Print out a value of the register type 1367register_print_fn :: RT.Rec -> [ C.Unit ] 1368register_print_fn r 1369 | RT.is_array r = 1370 [ register_print_array_element r, register_print_array r ] 1371 | otherwise = 1372 [ register_print_single r ] 1373 1374register_print_array_element :: RT.Rec -> C.Unit 1375register_print_array_element r = 1376 snprintf_like_defn (regarray_print_fn_name r) args body 1377 where 1378 args = [ C.Param (C.Ptr device_c_type) cv_dev, 1379 C.Param (C.TypeName "int") cv_i ] 1380 body = 1381 [ register_print_init r, 1382 snprintf_like_call "snprintf" 1383 [ C.StringConstant "Register %s[%d] (%s): ", 1384 C.StringConstant $ RT.name r, 1385 C.Variable cv_i, 1386 C.StringConstant $ RT.desc r ] 1387 ] ++ (register_print_value r) 1388 1389register_print_array :: RT.Rec -> C.Unit 1390register_print_array r = 1391 snprintf_like_defn (register_print_fn_name r) args body 1392 where 1393 args = [ C.Param (C.Ptr device_c_type) cv_dev ] 1394 body = [ simple_var "int" cv_i Nothing, 1395 simple_for (C.NumConstant $ RT.num_elements r) 1396 [ snprintf_like_call (regarray_print_fn_name r) 1397 [ C.Variable cv_dev, C.Variable cv_i ] 1398 ] 1399 ] 1400 1401register_print_single :: RT.Rec -> C.Unit 1402register_print_single r = 1403 snprintf_like_defn (register_print_fn_name r) args body 1404 where 1405 args = [ C.Param (C.Ptr device_c_type) cv_dev ] 1406 body = [ register_print_init r, 1407 snputs_like_call $ printf 1408 "Register %s (%s): " (RT.name r) (RT.desc r) 1409 ] ++ register_print_value r 1410 1411register_print_value :: RT.Rec -> [ C.Stmt ] 1412register_print_value r = 1413 case RT.tpe r of 1414 TT.RegFormat {} -> [ snputs_like_call "\n" ] 1415 ++ [ field_print_block (RT.tpe r) f | f <- (RT.fl r) ] 1416 TT.DataFormat {} -> [ snputs_like_call "\n" ] 1417 ++ [ field_print_block (RT.tpe r) f | f <- (RT.fl r) ] 1418 TT.Primitive {} -> [ register_print_primitive r ] 1419 TT.ConstType {} -> [ register_print_consttype r ] 1420 1421register_print_primitive :: RT.Rec -> C.Stmt 1422register_print_primitive r = 1423 let extra = 1424 if RT.needs_shadow r then " (SHADOW copy)" 1425 else "" 1426 fmt = C.StringCat [ C.QStr "\t%", 1427 C.NStr $ field_fmt_str $ RT.size r, 1428 C.QStr (extra ++ "\n") ] 1429 in snprintf_like_call "snprintf" [ fmt, C.Variable cv_regval ] 1430 1431register_print_consttype :: RT.Rec -> C.Stmt 1432register_print_consttype r = 1433 let extra = 1434 if RT.needs_shadow r then " (SHADOW copy)" 1435 else "" 1436 c = constants_print_fn_name $ TT.tt_name $ RT.tpe r 1437 in snprintf_like_call c [ C.Variable cv_regval ] 1438 1439register_print_init :: RT.Rec -> C.Stmt 1440register_print_init r = 1441 C.VarDecl C.NoScope C.NonConst (register_c_type r) cv_regval (Just expr) 1442 where expr = 1443 if RT.is_readable r then loc_read r 1444 else register_shadow_ref r 1445