1(* 2 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230) 3 * 4 * SPDX-License-Identifier: BSD-2-Clause 5 *) 6 7structure Main = struct 8 9open OS.Process 10 11 12(* takes a file name on the command-line, and attempts to parse it *) 13fun die s = (print s; print "\n"; exit failure) 14fun warn s = (TextIO.output(TextIO.stdErr, s^"\n"); 15 TextIO.flushOut TextIO.stdErr) 16val execname = CommandLine.name 17 18 19val _ = Feedback.errorThreshold := NONE; 20val _ = Feedback.informf := (fn s => (TextIO.output(TextIO.stdOut, s); 21 TextIO.flushOut TextIO.stdOut)) 22 23fun quote s = "\"" ^ s ^ "\"" 24 25 26val commas = String.concat o separate ", " 27fun writeln s = Feedback.informStr(0,s) 28 29fun print_addressed_vars cse = let 30 open ProgramAnalysis 31 val globs = get_globals cse 32 val pfx1 = "There are "^Int.toString (length globs)^ " globals: " 33 val _ = writeln (String.concat 34 (separate "\n " (pfx1 :: map srcname globs))) 35 val addressed = get_addressed cse 36 val addr_vars = map MString.dest (MSymTab.keys addressed) 37 val pfx2 = "There are "^Int.toString (length addr_vars)^ 38 " addressed variables: " 39 val _ = writeln (String.concatWith "\n " (pfx2 :: addr_vars)) 40in 41 () 42end 43 44fun print_embedded_fncalls cse = let 45 open ProgramAnalysis 46 val calls = get_embedded_fncalls cse 47 fun filter call = 48 case call of 49 DirectCall s => let 50 in 51 case get_modifies cse s of 52 NONE => SOME s 53 | SOME varset => if not (Binaryset.isEmpty varset) then SOME s 54 else NONE 55 end 56 | _ => NONE 57 val call_list = List.mapPartial filter (Binaryset.listItems calls) 58 val pfx = "These " ^ Int.toString (length call_list) ^ 59 " functions MUST be shown to be side-effect free (and don't look as if they are): " 60in 61 writeln (String.concat (separate "\n " (pfx :: call_list))) 62end 63 64val printmv = ProgramAnalysis.mvar_toString 65 66fun print_modifies cse = let 67 open ProgramAnalysis 68 val functions = get_functions cse 69 fun print f = let 70 val fnm = if is_recursivefn cse f then f ^ " (recursive)" else f 71 in 72 writeln (" " ^ StringCvt.padRight #" " 50 fnm ^ ": " ^ 73 (case get_modifies cse f of 74 NONE => "<is or calls unannotated proto>" 75 | SOME varset => 76 String.concat 77 (separate " " (map printmv (Binaryset.listItems varset))))) 78 end 79in 80 writeln "Modifies info:"; 81 app print functions 82end 83 84fun print_reads cse = let 85 open ProgramAnalysis 86 val functions = get_functions cse 87 val reads = get_read_globals cse 88 fun print f = let 89 val vars = Binaryset.foldr (fn (mv,acc) => printmv mv :: acc) 90 [] 91 (valOf (Symtab.lookup reads f)) 92 handle Option => ["<is or calls unannotated proto>"] 93 in 94 writeln (" " ^ StringCvt.padRight #" " 50 f ^ ": "^ 95 String.concat (separate " " vars)) 96 end 97in 98 writeln "Function reads:"; 99 app print functions 100end 101 102fun calc_protoes cse = let 103 open ProgramAnalysis 104 val functions = get_functions cse 105 val defined_functions = get_defined_functions cse 106 fun foldthis (f, acc) = 107 if isSome (Symtab.lookup defined_functions f) then acc 108 else Binaryset.add(acc, f) 109in 110 List.foldl foldthis (Binaryset.empty String.compare) functions 111end 112 113fun print_protoes cse = let 114in 115 writeln "Protoes (only):"; 116 Binaryset.app (fn v => writeln (" " ^ v)) (calc_protoes cse) 117end 118 119fun print_unmodified_globals cse = let 120in 121 writeln "Unmodifed, unaddressed globals:"; 122 writeln (" " ^ 123 (cse |> ProgramAnalysis.calc_untouched_globals 124 |> MSymTab.keys 125 |> map MString.dest 126 |> commas)) 127end 128 129val filename = ref "" 130fun produce_dotfile cse = let 131 open ProgramAnalysis 132 val os = TextIO.openOut (!filename ^ ".dot") 133 fun print s = TextIO.output(os, s ^ "\n") 134 val fns = get_functions cse 135 val {callgraph,...} = compute_callgraphs cse 136 fun print_fn f = let 137 val callees = case Symtab.lookup callgraph f of 138 NONE => Binaryset.empty String.compare 139 | SOME s => s 140 in 141 Binaryset.app (fn c => print (f ^ " -> " ^ c)) callees 142 end 143in 144 print "digraph {"; 145 print "graph[fontsize=8]"; 146 print "node[shape=plaintext]"; 147 List.app print_fn fns; 148 print "}"; 149 TextIO.closeOut os 150end 151 152fun produce_toposort cse = let 153 open ProgramAnalysis 154 fun lift f fnm = case Symtab.lookup f fnm of 155 NONE => [] 156 | SOME s => Binaryset.listItems s 157 val {callgraph,callers} = compute_callgraphs cse 158 val toposort = Topo_Sort.topo_sort {cmp = String.compare, 159 graph = lift callgraph, 160 converse = lift callers} 161 (get_functions cse) 162 fun printcomp [] = raise Fail "Empty SCC??" 163 | printcomp [x] = writeln (" "^x) 164 | printcomp list = writeln (" " ^ commas list) 165in 166 writeln "Topological sort of functions in callgraph"; 167 List.app printcomp toposort 168end 169 170 171fun print_uncalledfns cse = let 172 open ProgramAnalysis 173 val {callgraph = graph,...} = compute_callgraphs cse 174 val fns = get_functions cse 175 fun foldthis (fname, acc) = 176 case Symtab.lookup graph fname of 177 NONE => fname :: acc 178 | SOME s => if Binaryset.isEmpty s then fname::acc 179 else acc 180 val uncalled = List.foldl foldthis [] fns 181in 182 writeln "Uncalled functions"; 183 List.app (fn s => writeln (" "^s)) (List.rev uncalled) 184end 185 186fun print_fnspecs cse = let 187 open ProgramAnalysis Absyn 188 val specdb = function_specs cse 189 val _ = writeln "Function specification information:" 190 fun doit (fname, specs) () = let 191 in 192 writeln fname ; 193 List.app (fn fs => writeln (" "^fnspec2string fs)) specs 194 end 195in 196 Symtab.fold doit specdb () 197end 198 199 200datatype pc_problem = Reads of ProgramAnalysis.modify_var 201 | Writes of ProgramAnalysis.modify_var 202 | IsProto 203 204fun mapOne f s = 205 case Binaryset.find (fn _ => true) s of 206 NONE => NONE 207 | SOME i => SOME (f i) 208 209fun print_bogus_pures cse = let 210 open ProgramAnalysis Absyn 211 val specdb = function_specs cse 212 open Feedback 213 fun foldthis (fname, fspecs) () = let 214 open Binaryset 215 val idset = all_IDattributes fspecs 216 val pure_problem = 217 case get_modifies cse fname of 218 NONE => SOME IsProto 219 | SOME s => mapOne Writes s 220 val pc_attr = member(idset, "pure") orelse member(idset, "const") 221 in 222 if member(idset, "noreturn") then () 223 else 224 case pure_problem of 225 NONE => if not pc_attr then 226 informStr(2, "NOTE: "^fname^ 227 " is pure, but not annotated pure or const") 228 else () 229 | SOME (Writes mv) => 230 if pc_attr then 231 informStr(1, "WARNING: "^fname^ " writes "^printmv mv^ 232 " but is annotated pure or const") 233 else () 234 | SOME IsProto => 235 if pc_attr then 236 informStr(1, "WARNING: "^fname^" is annotated pure or const, but \ 237 \is an unannotated prototype") 238 else () 239 | SOME _ => (* can't happen *) () 240 end 241in 242 Symtab.fold foldthis specdb () 243end 244 245fun print_bogus_consts cse = let 246 open ProgramAnalysis Absyn 247 val specdb = function_specs cse 248 val read_globals = get_read_globals cse 249 fun foldthis (fname, fspecs) () = let 250 val reads_prob = 251 case Symtab.lookup read_globals fname of 252 NONE => SOME IsProto 253 | SOME s => mapOne Reads s 254 val prob = 255 case reads_prob of 256 NONE => let 257 in 258 case get_modifies cse fname of 259 NONE => SOME IsProto 260 | SOME s => mapOne Writes s 261 end 262 | x => x 263 val idset = all_IDattributes fspecs 264 open Binaryset Feedback 265 fun prob2str IsProto = "is or calls a proto" 266 | prob2str (Reads mv) = "reads "^printmv mv 267 | prob2str (Writes mv) = "writes "^printmv mv 268 in 269 if member(idset, "noreturn") then () 270 else 271 case prob of 272 NONE => if not (member(idset, "const")) then 273 informStr(2, "NOTE: "^fname^ 274 " is const, but not annotated const") 275 else () 276 | SOME p => if member (idset, "const") then 277 informStr(1, "WARNING: "^fname^" is declared const but "^ 278 prob2str p) 279 else () 280 end 281in 282 Symtab.fold foldthis specdb () 283end 284 285 286fun print_unannotated_protoes cse = let 287 open ProgramAnalysis 288 val protoes = calc_protoes cse 289 fun foldthis (fnm, acc) = 290 case get_modifies cse fnm of 291 NONE => fnm::acc 292 | SOME _ => acc 293in 294 writeln "Unannotated protoes:"; 295 List.app (fn s => writeln (" "^s)) 296 (List.rev (Binaryset.foldl foldthis [] protoes)) 297end 298 299fun mmsizes cse = let 300 open Absyn ProgramAnalysis 301 val fns = get_fninfo cse 302 fun foldthis (name,(rettype,_,pvis)) _ = let 303 fun bytesize ty = case ty of Void => 0 | _ => sizeof cse ty 304 val retsize = bytesize rettype 305 val psizes = map (bytesize o get_vi_type) pvis 306 in 307 print (String.concatWith " " (Int.toString retsize :: name :: 308 map Int.toString psizes)); 309 print "\n" 310 end 311in 312 Symtab.fold foldthis fns () 313end 314 315 316fun equal x y = (x = y) 317 318fun cmdline_options hdlr args = let 319 fun recurse args = 320 case args of 321 [] => args 322 | h::t => if h = "--" then t 323 else if String.isPrefix "--" h then let 324 val h' = String.extract (h, 2, NONE) 325 val flds = String.fields (equal #"=") h' 326 in 327 if length flds = 1 then (hdlr (h', NONE); recurse t) 328 else let 329 val a = hd flds 330 val () = hdlr (a, SOME (String.extract(h',size a,NONE))) 331 in 332 recurse t 333 end 334 end 335 else if String.isPrefix "-" h andalso size h > 1 then let 336 in 337 if size h > 2 then 338 hdlr(String.substring(h,1,1), 339 SOME (String.extract(h,2,NONE))) 340 else 341 hdlr(String.substring(h,1,1), NONE); 342 recurse t 343 end 344 else h::t 345in 346 recurse args 347end 348 349fun decl_toString d = let 350 open Absyn 351in 352 case d of 353 VarDecl (_, sw, _, _, _) => "declaration of global variable "^node sw 354 | StructDecl (sw, _) => "declaration of struct "^node sw 355 | TypeDecl tynms => "typedef of "^ 356 String.concatWith ", " (map (node o #2) tynms) 357 | ExtFnDecl {name,...} => "declaration of function "^node name 358 | EnumDecl (sow,_) => "declaration of "^(case node sow of 359 NONE => "anonymous" 360 | SOME s => s)^ 361 " enum" 362end 363 364fun print_fnslocs cse ast = let 365 open Absyn 366 fun recurse [] = () 367 | recurse (Decl dw :: t) = 368 (warn ("Ignoring "^decl_toString (node dw)); recurse t) 369 | recurse (FnDefn ((retty,fnm),params,specs,body) :: t) = 370 (print (node fnm^" " ^ 371 SourcePos.toString (left fnm) ^ " " ^ 372 SourcePos.toString (right body)^"\n"); 373 recurse t) 374in 375 recurse ast 376end 377 378fun print_ast cse ast = let 379 open Absyn_Serial 380 381 fun serial_defn (FnDefn ((retty,fnm),params,specs,body)) 382 = Nm ("Function", [varspec_serial (retty,fnm), 383 list_serial varspec_serial params, 384 list_serial fnspec_serial specs, 385 list_serial bi_serial (node body)]) 386 | serial_defn (Decl dw) = decl_serial (node dw) 387 fun print_lines ss = app print (map (fn s => s ^ "\n") ss) 388in 389 app (print_lines o lines_serial o serial_defn) ast 390end 391 392fun adjusted_complex_fncalls cse ast = let 393 open Absyn_Serial 394 395 fun is_adjusted s = case snode s of 396 Assign(_,e) => (case enode e of EFnCall _ => true | _ => false) 397 | Return(SOME e) => (case enode e of EFnCall _ => true | _ => false) 398 | _ => false 399 fun note_adjusteds s = if is_adjusted s 400 then print ("adjusted fncall at: " ^ 401 SourcePos.toString (sleft s) ^ " " ^ 402 SourcePos.toString (sright s)^"\n") 403 else app note_adjusteds (sub_stmts s) 404 fun note_bi (BI_Stmt s) = note_adjusteds s 405 | note_bi _ = () 406 fun note_defn (FnDefn (_,_,_,body)) 407 = app note_bi (node body) 408 | note_defn _ = () 409in app note_defn ast end 410 411fun unhandled_asm cse ast = let 412 open Absyn 413 fun warn_asm asm = K () (ProgramAnalysis.split_asm_stmt asm) 414 handle Fail s => print s 415 fun warn_stmt s = case snode s of 416 (AsmStmt asm) => warn_asm (AsmStmt asm) 417 | _ => app warn_stmt (sub_stmts s) 418 fun warn_bi (BI_Stmt s) = warn_stmt s 419 | warn_bi _ = () 420 fun warn_defn (FnDefn (_,_,_,body)) 421 = app warn_bi (node body) 422 | warn_defn _ = () 423in app warn_defn ast end 424 425val analyses = ref ([] : (ProgramAnalysis.csenv -> Absyn.ext_decl list -> unit) list) 426val includes = ref ([] : string list) 427val error_lookahead = ref 15 428val verbosity = Feedback.verbosity_level 429 430fun add_analysis f = analyses := f :: !analyses 431fun add_cse_analysis f = analyses := (fn cse => fn ast => f cse) :: !analyses 432 433val cpp = ref (SOME "/usr/bin/cpp") 434val parse_only = ref false 435val underscore_idents = ref false 436val show_help = ref false 437val bad_option = ref false 438val munge_info_fname = ref (NONE : string option) 439 440val options = let 441 open GetOpt 442 fun intref r s = 443 case Int.fromString s of 444 NONE => (show_help := true; bad_option := true) 445 | SOME i => r := i 446 fun cse_analysis nm f = 447 {short = "", long = [nm], help = "Do "^nm^" analysis", 448 desc = NoArg (fn () => add_cse_analysis f)} 449 fun ast_analysis nm f = 450 {short = "", long = [nm], help = "Do "^nm^" analysis", 451 desc = NoArg (fn () => add_analysis f)} 452in 453 [{short = "h?", long = ["help"], help = "Show usage information", 454 desc = NoArg (fn () => show_help := true)}, 455 {short = "I", long = [], help = "Add include directory (repeatable)", 456 desc = ReqArg ((fn dir => includes := dir :: !includes), "directory")}, 457 {short = "v", long = [], help = "Set parser error verbosity", 458 desc = ReqArg (intref verbosity, "number")}, 459 {short = "l", long = [], help = "Set parser lookahead", 460 desc = ReqArg (intref error_lookahead, "number")}, 461 cse_analysis "addressed_vars" print_addressed_vars, 462 cse_analysis "bogus_const" print_bogus_consts, 463 cse_analysis "bogus_pure" print_bogus_pures, 464 {short = "", long = ["cpp"], help = "Set cpp path (see also --nocpp)", 465 desc = ReqArg ((fn p => cpp := SOME p), "path")}, 466 cse_analysis "embedded_fncalls" print_embedded_fncalls, 467 ast_analysis "fnslocs" print_fnslocs, 468 cse_analysis "fnspecs" print_fnspecs, 469 cse_analysis "mmbytes" mmsizes, 470 cse_analysis "modifies" print_modifies, 471 {short = "", long = ["munge_info_fname"], help = "Path for munge info", 472 desc = ReqArg ((fn p => munge_info_fname := SOME p), "path")}, 473 {short = "", long = ["nocpp"], help = "Don't use cpp", 474 desc = NoArg (fn () => cpp := NONE)}, 475 {short = "", long = ["nolinedirectives"], help = "Ignore #line directives", 476 desc = NoArg (fn () => SourceFile.observe_line_directives := false)}, 477 cse_analysis "protoes" print_protoes, 478 {short = "", long = ["rawsyntaxonly"], help = "Don't perform any analyses", 479 desc = NoArg (fn () => parse_only := true)}, 480 {short = "", long = ["underscore_idents"], help = "Allow identifiers starting with underscores", 481 desc = NoArg (fn () => underscore_idents := true)}, 482 cse_analysis "reads" print_reads, 483 cse_analysis "toposort" produce_toposort, 484 cse_analysis "produce dotfile" produce_dotfile, 485 cse_analysis "unannotated_protoes" print_unannotated_protoes, 486 cse_analysis "uncalledfns" print_uncalledfns, 487 cse_analysis "unmodifiedglobs" print_unmodified_globals, 488 ast_analysis "ast" print_ast, 489 ast_analysis "adjusted_complex_fncalls" adjusted_complex_fncalls, 490 ast_analysis "unhandled_asm" unhandled_asm 491 ] 492end 493 494 495 496 497fun docpp (SOME p) {includes, filename} = 498 let 499 val includes_string = String.concat (map (fn s => "-I\""^s^"\" ") includes) 500 open OS.FileSys OS.Process 501 val tmpname = tmpName() 502 val cmdline = 503 p ^ " " ^ includes_string ^ " -CC \"" ^ filename ^ "\" > " ^ tmpname 504 in 505 if isSuccess (system cmdline) then (tmpname, true) 506 else raise Feedback.WantToExit ("cpp failed on "^filename) 507 end 508 | docpp NONE {filename, ...} = (filename, false) 509 510val usage_msg = GetOpt.usageInfo { 511 header = 512 "Usage: \n "^execname()^" [options] filename\n\n\ 513 \Use -l to adjust error lookahead. (The higher the number, the more the parser\n\ 514 \will try to make sense of stuff with parse errors.)\n\n\ 515 \For no analyses at all (not even typechecking), use --rawsyntaxonly.\n\n\ 516 \All options:\n", 517 options = options 518 } 519 520 521 522fun doit args = 523 let 524 val (_, realargs) = 525 GetOpt.getOpt {argOrder = GetOpt.RequireOrder, options = options, 526 errFn = die} args 527 val _ = if !show_help then 528 (print usage_msg ; OS.Process.exit OS.Process.success) 529 else if !bad_option then die usage_msg 530 else () 531 in 532 case realargs of 533 [] => die usage_msg 534 | [fname] => 535 let 536 val (ast,n) = StrictCParser.parse (docpp (!cpp)) (!error_lookahead) 537 (List.rev (!includes)) fname 538 in 539 if !parse_only then () 540 else 541 let 542 val ((ast', inits), cse) = 543 ProgramAnalysis.process_decls 544 {anon_vars = false, owners = [], 545 munge_info_fname = !munge_info_fname, 546 allow_underscore_idents = !underscore_idents} 547 (SyntaxTransforms.remove_typedefs ast) 548 val _ = ProgramAnalysis.export_mungedb cse 549 val _ = filename := fname 550 fun do_analyses alist = 551 case alist of 552 [] => exit (if !Feedback.numErrors = 0 then success else failure) 553 | f::fs => let 554 val () = f cse ast' 555 in 556 do_analyses fs 557 end 558 in 559 do_analyses (List.rev (!analyses)) 560 end 561 end 562 | _ => die usage_msg 563 end 564 565end; 566