From a5f03d96eee482cd84861fc8cefff9eb451c0cad Mon Sep 17 00:00:00 2001 From: xleroy Date: Sun, 29 Mar 2009 09:47:11 +0000 Subject: Cleaned up configure script. Distribution of CIL as an expanded source tree with changes applied (instead of original .tar.gz + patches to be applied at config time). git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1020 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e --- LICENSE | 14 +- cil-1.3.5.tar.gz | Bin 1139611 -> 0 bytes cil.patch/Makefile.in.patch | 23 - cil.patch/astslicer.ml.patch | 40 - cil.patch/cabs2cil.ml.patch | 457 -- cil.patch/cfg.ml.patch | 55 - cil.patch/check.ml.patch | 56 - cil.patch/cil.ml.patch | 381 -- cil.patch/cil.mli.patch | 59 - cil.patch/clexer.mll.patch | 24 - cil.patch/dataflow.ml.patch | 27 - cil.patch/dataslicing.ml.patch | 28 - cil.patch/formatparse.mly.patch | 40 - cil.patch/mergecil.ml.patch | 25 - cil.patch/oneret.ml.patch | 38 - cil.patch/ptranal.ml.patch | 28 - cil.patch/usedef.ml.patch | 38 - cil/INSTALL | 41 + cil/LICENSE | 35 + cil/Makefile.gcc | 75 + cil/Makefile.in | 656 +++ cil/Makefile.msvc | 42 + cil/README | 2 + cil/bin/CilConfig.pm.in | 6 + cil/bin/cilly | 152 + cil/bin/cilly.bat.in | 1 + cil/bin/patcher | 605 ++ cil/bin/patcher.bat.in | 1 + cil/bin/teetwo | 36 + cil/bin/test-bad | 202 + cil/cil.spec | 90 + cil/cil.spec.in | 90 + cil/config.guess | 1497 +++++ cil/config.h.in | 23 + cil/config.sub | 1469 +++++ cil/configure | 5697 +++++++++++++++++++ cil/configure.in | 600 ++ cil/doc/CIL-API.pdf | Bin 0 -> 226152 bytes cil/doc/CIL.pdf | Bin 0 -> 269328 bytes cil/doc/api/Alpha.html | 79 + cil/doc/api/Cfg.html | 69 + cil/doc/api/Cil.cilPrinter.html | 118 + cil/doc/api/Cil.cilVisitor.html | 125 + cil/doc/api/Cil.defaultCilPrinterClass.html | 36 + cil/doc/api/Cil.html | 3337 +++++++++++ cil/doc/api/Cil.nopCilVisitor.html | 35 + cil/doc/api/Cil.plainCilPrinterClass.html | 36 + cil/doc/api/Cillower.html | 40 + cil/doc/api/Clist.html | 118 + cil/doc/api/Dataflow.BackwardsDataFlow.html | 54 + cil/doc/api/Dataflow.BackwardsTransfer.html | 83 + cil/doc/api/Dataflow.ForwardsDataFlow.html | 53 + cil/doc/api/Dataflow.ForwardsTransfer.html | 88 + cil/doc/api/Dataflow.html | 114 + cil/doc/api/Dominators.html | 58 + cil/doc/api/Errormsg.html | 141 + cil/doc/api/Formatcil.html | 84 + cil/doc/api/Pretty.MakeMapPrinter.html | 63 + cil/doc/api/Pretty.MakeSetPrinter.html | 63 + cil/doc/api/Pretty.html | 268 + cil/doc/api/Stats.html | 69 + cil/doc/api/index.html | 83 + cil/doc/api/index_attributes.html | 30 + cil/doc/api/index_class_types.html | 41 + cil/doc/api/index_classes.html | 46 + cil/doc/api/index_exceptions.html | 53 + cil/doc/api/index_methods.html | 228 + cil/doc/api/index_module_types.html | 36 + cil/doc/api/index_modules.html | 108 + cil/doc/api/index_types.html | 271 + cil/doc/api/index_values.html | 1964 +++++++ cil/doc/api/style.css | 32 + cil/doc/api/type_Alpha.html | 43 + cil/doc/api/type_Cfg.html | 35 + cil/doc/api/type_Cil.cilPrinter.html | 48 + cil/doc/api/type_Cil.cilVisitor.html | 43 + cil/doc/api/type_Cil.defaultCilPrinterClass.html | 25 + cil/doc/api/type_Cil.html | 622 +++ cil/doc/api/type_Cil.nopCilVisitor.html | 25 + cil/doc/api/type_Cil.plainCilPrinterClass.html | 25 + cil/doc/api/type_Cillower.html | 25 + cil/doc/api/type_Clist.html | 44 + cil/doc/api/type_Dataflow.BackwardsDataFlow.html | 26 + cil/doc/api/type_Dataflow.BackwardsTransfer.html | 44 + cil/doc/api/type_Dataflow.ForwardsDataFlow.html | 25 + cil/doc/api/type_Dataflow.ForwardsTransfer.html | 51 + cil/doc/api/type_Dataflow.html | 85 + cil/doc/api/type_Dominators.html | 32 + cil/doc/api/type_Errormsg.html | 64 + cil/doc/api/type_Formatcil.html | 45 + cil/doc/api/type_Pretty.MakeMapPrinter.html | 42 + cil/doc/api/type_Pretty.MakeSetPrinter.html | 40 + cil/doc/api/type_Pretty.html | 111 + cil/doc/api/type_Stats.html | 36 + cil/doc/changes.html | 486 ++ cil/doc/cil.css | 10 + cil/doc/cil.html | 3532 ++++++++++++ cil/doc/cil.version.tex | 2 + cil/doc/cil001.html | 134 + cil/doc/cil002.html | 98 + cil/doc/cil003.html | 187 + cil/doc/cil004.html | 350 ++ cil/doc/cil006.html | 627 +++ cil/doc/cil007.html | 279 + cil/doc/cil009.html | 48 + cil/doc/cil010.html | 100 + cil/doc/cil011.html | 53 + cil/doc/cil012.html | 133 + cil/doc/cil015.html | 60 + cil/doc/cil016.html | 342 ++ cil/doc/cil017.html | 53 + cil/doc/cil018.html | 71 + cil/doc/cil019.html | 45 + cil/doc/cilly.html | 187 + cil/doc/cilpp.haux | 64 + cil/doc/cilpp.htoc | 65 + cil/doc/ciltoc.html | 92 + cil/doc/contents_motif.gif | Bin 0 -> 316 bytes cil/doc/examples/ex1.txt | 16 + cil/doc/examples/ex10.txt | 10 + cil/doc/examples/ex11.txt | 5 + cil/doc/examples/ex12.txt | 32 + cil/doc/examples/ex13.txt | 21 + cil/doc/examples/ex14.txt | 22 + cil/doc/examples/ex15.txt | 14 + cil/doc/examples/ex16.txt | 22 + cil/doc/examples/ex17.txt | 81 + cil/doc/examples/ex18.txt | 20 + cil/doc/examples/ex19.txt | 42 + cil/doc/examples/ex2.txt | 9 + cil/doc/examples/ex20.txt | 26 + cil/doc/examples/ex21.txt | 25 + cil/doc/examples/ex22.txt | 16 + cil/doc/examples/ex23.txt | 56 + cil/doc/examples/ex24.txt | 59 + cil/doc/examples/ex25.txt | 40 + cil/doc/examples/ex26.txt | 29 + cil/doc/examples/ex27.txt | 51 + cil/doc/examples/ex28.txt | 24 + cil/doc/examples/ex29.txt | 53 + cil/doc/examples/ex3.txt | 20 + cil/doc/examples/ex30.txt | 12 + cil/doc/examples/ex31.txt | 12 + cil/doc/examples/ex32.txt | 16 + cil/doc/examples/ex33.txt | 24 + cil/doc/examples/ex34.txt | 15 + cil/doc/examples/ex35.txt | 32 + cil/doc/examples/ex36.txt | 20 + cil/doc/examples/ex37.txt | 14 + cil/doc/examples/ex38.txt | 12 + cil/doc/examples/ex39.txt | 25 + cil/doc/examples/ex4.txt | 16 + cil/doc/examples/ex40.txt | 20 + cil/doc/examples/ex41.txt | 69 + cil/doc/examples/ex42.txt | 22 + cil/doc/examples/ex43.txt | 46 + cil/doc/examples/ex44.txt | 31 + cil/doc/examples/ex45.txt | 11 + cil/doc/examples/ex46.txt | 23 + cil/doc/examples/ex47.txt | 28 + cil/doc/examples/ex5.txt | 27 + cil/doc/examples/ex6.txt | 7 + cil/doc/examples/ex7.txt | 22 + cil/doc/examples/ex8.txt | 13 + cil/doc/examples/ex9.txt | 16 + cil/doc/ext.html | 506 ++ cil/doc/header.html | 18 + cil/doc/index.html | 26 + cil/doc/merger.html | 167 + cil/doc/next_motif.gif | Bin 0 -> 317 bytes cil/doc/patcher.html | 126 + cil/doc/previous_motif.gif | Bin 0 -> 317 bytes cil/install-sh | 251 + cil/lib/Cilly.pm | 2137 +++++++ cil/lib/KeptFile.pm | 88 + cil/lib/OutputFile.pm | 213 + cil/lib/TempFile.pm | 90 + cil/ocamlutil/Makefile.ocaml | 395 ++ cil/ocamlutil/Makefile.ocaml.build | 50 + cil/ocamlutil/alpha.ml | 156 + cil/ocamlutil/alpha.mli | 50 + cil/ocamlutil/clist.ml | 183 + cil/ocamlutil/clist.mli | 97 + cil/ocamlutil/errormsg.ml | 337 ++ cil/ocamlutil/errormsg.mli | 164 + cil/ocamlutil/growArray.ml | 191 + cil/ocamlutil/growArray.mli | 131 + cil/ocamlutil/inthash.ml | 188 + cil/ocamlutil/inthash.mli | 27 + cil/ocamlutil/intmap.ml | 171 + cil/ocamlutil/intmap.mli | 87 + cil/ocamlutil/perfcount.c.in | 184 + cil/ocamlutil/pretty.ml | 859 +++ cil/ocamlutil/pretty.mli | 316 ++ cil/ocamlutil/stats.ml | 146 + cil/ocamlutil/stats.mli | 72 + cil/ocamlutil/trace.ml | 169 + cil/ocamlutil/trace.mli | 106 + cil/ocamlutil/util.ml | 815 +++ cil/ocamlutil/util.mli | 311 ++ cil/src/check.ml | 1017 ++++ cil/src/check.mli | 45 + cil/src/cil.ml | 6427 ++++++++++++++++++++++ cil/src/cil.mli | 2455 +++++++++ cil/src/cillower.ml | 57 + cil/src/cillower.mli | 42 + cil/src/ciloptions.ml | 196 + cil/src/ciloptions.mli | 48 + cil/src/cilutil.ml | 72 + cil/src/escape.ml | 93 + cil/src/escape.mli | 48 + cil/src/ext/astslicer.ml | 454 ++ cil/src/ext/availexps.ml | 359 ++ cil/src/ext/bitmap.ml | 224 + cil/src/ext/bitmap.mli | 50 + cil/src/ext/blockinggraph.ml | 769 +++ cil/src/ext/blockinggraph.mli | 40 + cil/src/ext/callgraph.ml | 250 + cil/src/ext/callgraph.mli | 123 + cil/src/ext/canonicalize.ml | 292 + cil/src/ext/canonicalize.mli | 48 + cil/src/ext/cfg.ml | 289 + cil/src/ext/cfg.mli | 36 + cil/src/ext/ciltools.ml | 228 + cil/src/ext/dataflow.ml | 466 ++ cil/src/ext/dataflow.mli | 151 + cil/src/ext/dataslicing.ml | 462 ++ cil/src/ext/dataslicing.mli | 41 + cil/src/ext/deadcodeelim.ml | 173 + cil/src/ext/dominators.ml | 241 + cil/src/ext/dominators.mli | 29 + cil/src/ext/epicenter.ml | 114 + cil/src/ext/heap.ml | 112 + cil/src/ext/heapify.ml | 250 + cil/src/ext/liveness.ml | 190 + cil/src/ext/logcalls.ml | 268 + cil/src/ext/logcalls.mli | 41 + cil/src/ext/logwrites.ml | 139 + cil/src/ext/oneret.ml | 187 + cil/src/ext/oneret.mli | 44 + cil/src/ext/partial.ml | 851 +++ cil/src/ext/pta/golf.ml | 1657 ++++++ cil/src/ext/pta/golf.mli | 83 + cil/src/ext/pta/olf.ml | 1108 ++++ cil/src/ext/pta/olf.mli | 80 + cil/src/ext/pta/ptranal.ml | 597 ++ cil/src/ext/pta/ptranal.mli | 156 + cil/src/ext/pta/setp.ml | 342 ++ cil/src/ext/pta/setp.mli | 180 + cil/src/ext/pta/steensgaard.ml | 1417 +++++ cil/src/ext/pta/steensgaard.mli | 71 + cil/src/ext/pta/uref.ml | 94 + cil/src/ext/pta/uref.mli | 65 + cil/src/ext/reachingdefs.ml | 511 ++ cil/src/ext/sfi.ml | 337 ++ cil/src/ext/simplemem.ml | 132 + cil/src/ext/simplify.ml | 845 +++ cil/src/ext/ssa.ml | 696 +++ cil/src/ext/ssa.mli | 45 + cil/src/ext/stackoverflow.ml | 246 + cil/src/ext/stackoverflow.mli | 43 + cil/src/ext/usedef.ml | 188 + cil/src/formatcil.ml | 215 + cil/src/formatcil.mli | 103 + cil/src/formatlex.mll | 308 ++ cil/src/formatparse.mly | 1455 +++++ cil/src/frontc/cabs.ml | 396 ++ cil/src/frontc/cabs2cil.ml | 6238 +++++++++++++++++++++ cil/src/frontc/cabs2cil.mli | 49 + cil/src/frontc/cabsvisit.ml | 577 ++ cil/src/frontc/cabsvisit.mli | 115 + cil/src/frontc/clexer.mli | 55 + cil/src/frontc/clexer.mll | 664 +++ cil/src/frontc/cparser.mly | 1521 +++++ cil/src/frontc/cprint.ml | 1014 ++++ cil/src/frontc/frontc.ml | 256 + cil/src/frontc/frontc.mli | 55 + cil/src/frontc/lexerhack.ml | 22 + cil/src/frontc/patch.ml | 837 +++ cil/src/frontc/patch.mli | 42 + cil/src/libmaincil.ml | 108 + cil/src/machdep.c | 220 + cil/src/main.ml | 288 + cil/src/mergecil.ml | 1770 ++++++ cil/src/mergecil.mli | 42 + cil/src/rmtmps.ml | 778 +++ cil/src/rmtmps.mli | 82 + cil/src/testcil.ml | 440 ++ cil/test/small1/func.c | 24 + cil/test/small1/hello.c | 8 + cil/test/small1/init.c | 177 + cil/test/small1/init1.c | 17 + cil/test/small1/testharness.h | 17 + cil/test/small1/vararg1.c | 47 + cil/test/small1/wchar1.c | 24 + configure | 112 +- 296 files changed, 82317 insertions(+), 1356 deletions(-) delete mode 100644 cil-1.3.5.tar.gz delete mode 100644 cil.patch/Makefile.in.patch delete mode 100644 cil.patch/astslicer.ml.patch delete mode 100644 cil.patch/cabs2cil.ml.patch delete mode 100644 cil.patch/cfg.ml.patch delete mode 100644 cil.patch/check.ml.patch delete mode 100644 cil.patch/cil.ml.patch delete mode 100644 cil.patch/cil.mli.patch delete mode 100644 cil.patch/clexer.mll.patch delete mode 100644 cil.patch/dataflow.ml.patch delete mode 100644 cil.patch/dataslicing.ml.patch delete mode 100644 cil.patch/formatparse.mly.patch delete mode 100644 cil.patch/mergecil.ml.patch delete mode 100644 cil.patch/oneret.ml.patch delete mode 100644 cil.patch/ptranal.ml.patch delete mode 100644 cil.patch/usedef.ml.patch create mode 100644 cil/INSTALL create mode 100644 cil/LICENSE create mode 100644 cil/Makefile.gcc create mode 100644 cil/Makefile.in create mode 100644 cil/Makefile.msvc create mode 100644 cil/README create mode 100644 cil/bin/CilConfig.pm.in create mode 100755 cil/bin/cilly create mode 100755 cil/bin/cilly.bat.in create mode 100755 cil/bin/patcher create mode 100755 cil/bin/patcher.bat.in create mode 100755 cil/bin/teetwo create mode 100755 cil/bin/test-bad create mode 100644 cil/cil.spec create mode 100644 cil/cil.spec.in create mode 100755 cil/config.guess create mode 100644 cil/config.h.in create mode 100755 cil/config.sub create mode 100755 cil/configure create mode 100644 cil/configure.in create mode 100644 cil/doc/CIL-API.pdf create mode 100644 cil/doc/CIL.pdf create mode 100644 cil/doc/api/Alpha.html create mode 100644 cil/doc/api/Cfg.html create mode 100644 cil/doc/api/Cil.cilPrinter.html create mode 100644 cil/doc/api/Cil.cilVisitor.html create mode 100644 cil/doc/api/Cil.defaultCilPrinterClass.html create mode 100644 cil/doc/api/Cil.html create mode 100644 cil/doc/api/Cil.nopCilVisitor.html create mode 100644 cil/doc/api/Cil.plainCilPrinterClass.html create mode 100644 cil/doc/api/Cillower.html create mode 100644 cil/doc/api/Clist.html create mode 100644 cil/doc/api/Dataflow.BackwardsDataFlow.html create mode 100644 cil/doc/api/Dataflow.BackwardsTransfer.html create mode 100644 cil/doc/api/Dataflow.ForwardsDataFlow.html create mode 100644 cil/doc/api/Dataflow.ForwardsTransfer.html create mode 100644 cil/doc/api/Dataflow.html create mode 100644 cil/doc/api/Dominators.html create mode 100644 cil/doc/api/Errormsg.html create mode 100644 cil/doc/api/Formatcil.html create mode 100644 cil/doc/api/Pretty.MakeMapPrinter.html create mode 100644 cil/doc/api/Pretty.MakeSetPrinter.html create mode 100644 cil/doc/api/Pretty.html create mode 100644 cil/doc/api/Stats.html create mode 100644 cil/doc/api/index.html create mode 100644 cil/doc/api/index_attributes.html create mode 100644 cil/doc/api/index_class_types.html create mode 100644 cil/doc/api/index_classes.html create mode 100644 cil/doc/api/index_exceptions.html create mode 100644 cil/doc/api/index_methods.html create mode 100644 cil/doc/api/index_module_types.html create mode 100644 cil/doc/api/index_modules.html create mode 100644 cil/doc/api/index_types.html create mode 100644 cil/doc/api/index_values.html create mode 100644 cil/doc/api/style.css create mode 100644 cil/doc/api/type_Alpha.html create mode 100644 cil/doc/api/type_Cfg.html create mode 100644 cil/doc/api/type_Cil.cilPrinter.html create mode 100644 cil/doc/api/type_Cil.cilVisitor.html create mode 100644 cil/doc/api/type_Cil.defaultCilPrinterClass.html create mode 100644 cil/doc/api/type_Cil.html create mode 100644 cil/doc/api/type_Cil.nopCilVisitor.html create mode 100644 cil/doc/api/type_Cil.plainCilPrinterClass.html create mode 100644 cil/doc/api/type_Cillower.html create mode 100644 cil/doc/api/type_Clist.html create mode 100644 cil/doc/api/type_Dataflow.BackwardsDataFlow.html create mode 100644 cil/doc/api/type_Dataflow.BackwardsTransfer.html create mode 100644 cil/doc/api/type_Dataflow.ForwardsDataFlow.html create mode 100644 cil/doc/api/type_Dataflow.ForwardsTransfer.html create mode 100644 cil/doc/api/type_Dataflow.html create mode 100644 cil/doc/api/type_Dominators.html create mode 100644 cil/doc/api/type_Errormsg.html create mode 100644 cil/doc/api/type_Formatcil.html create mode 100644 cil/doc/api/type_Pretty.MakeMapPrinter.html create mode 100644 cil/doc/api/type_Pretty.MakeSetPrinter.html create mode 100644 cil/doc/api/type_Pretty.html create mode 100644 cil/doc/api/type_Stats.html create mode 100644 cil/doc/changes.html create mode 100644 cil/doc/cil.css create mode 100644 cil/doc/cil.html create mode 100644 cil/doc/cil.version.tex create mode 100644 cil/doc/cil001.html create mode 100644 cil/doc/cil002.html create mode 100644 cil/doc/cil003.html create mode 100644 cil/doc/cil004.html create mode 100644 cil/doc/cil006.html create mode 100644 cil/doc/cil007.html create mode 100644 cil/doc/cil009.html create mode 100644 cil/doc/cil010.html create mode 100644 cil/doc/cil011.html create mode 100644 cil/doc/cil012.html create mode 100644 cil/doc/cil015.html create mode 100644 cil/doc/cil016.html create mode 100644 cil/doc/cil017.html create mode 100644 cil/doc/cil018.html create mode 100644 cil/doc/cil019.html create mode 100644 cil/doc/cilly.html create mode 100644 cil/doc/cilpp.haux create mode 100644 cil/doc/cilpp.htoc create mode 100644 cil/doc/ciltoc.html create mode 100644 cil/doc/contents_motif.gif create mode 100644 cil/doc/examples/ex1.txt create mode 100644 cil/doc/examples/ex10.txt create mode 100644 cil/doc/examples/ex11.txt create mode 100644 cil/doc/examples/ex12.txt create mode 100644 cil/doc/examples/ex13.txt create mode 100644 cil/doc/examples/ex14.txt create mode 100644 cil/doc/examples/ex15.txt create mode 100644 cil/doc/examples/ex16.txt create mode 100644 cil/doc/examples/ex17.txt create mode 100644 cil/doc/examples/ex18.txt create mode 100644 cil/doc/examples/ex19.txt create mode 100644 cil/doc/examples/ex2.txt create mode 100644 cil/doc/examples/ex20.txt create mode 100644 cil/doc/examples/ex21.txt create mode 100644 cil/doc/examples/ex22.txt create mode 100644 cil/doc/examples/ex23.txt create mode 100644 cil/doc/examples/ex24.txt create mode 100644 cil/doc/examples/ex25.txt create mode 100644 cil/doc/examples/ex26.txt create mode 100644 cil/doc/examples/ex27.txt create mode 100644 cil/doc/examples/ex28.txt create mode 100644 cil/doc/examples/ex29.txt create mode 100644 cil/doc/examples/ex3.txt create mode 100644 cil/doc/examples/ex30.txt create mode 100644 cil/doc/examples/ex31.txt create mode 100644 cil/doc/examples/ex32.txt create mode 100644 cil/doc/examples/ex33.txt create mode 100644 cil/doc/examples/ex34.txt create mode 100644 cil/doc/examples/ex35.txt create mode 100644 cil/doc/examples/ex36.txt create mode 100644 cil/doc/examples/ex37.txt create mode 100644 cil/doc/examples/ex38.txt create mode 100644 cil/doc/examples/ex39.txt create mode 100644 cil/doc/examples/ex4.txt create mode 100644 cil/doc/examples/ex40.txt create mode 100644 cil/doc/examples/ex41.txt create mode 100644 cil/doc/examples/ex42.txt create mode 100644 cil/doc/examples/ex43.txt create mode 100644 cil/doc/examples/ex44.txt create mode 100644 cil/doc/examples/ex45.txt create mode 100644 cil/doc/examples/ex46.txt create mode 100644 cil/doc/examples/ex47.txt create mode 100644 cil/doc/examples/ex5.txt create mode 100644 cil/doc/examples/ex6.txt create mode 100644 cil/doc/examples/ex7.txt create mode 100644 cil/doc/examples/ex8.txt create mode 100644 cil/doc/examples/ex9.txt create mode 100644 cil/doc/ext.html create mode 100644 cil/doc/header.html create mode 100644 cil/doc/index.html create mode 100644 cil/doc/merger.html create mode 100644 cil/doc/next_motif.gif create mode 100644 cil/doc/patcher.html create mode 100644 cil/doc/previous_motif.gif create mode 100644 cil/install-sh create mode 100644 cil/lib/Cilly.pm create mode 100644 cil/lib/KeptFile.pm create mode 100644 cil/lib/OutputFile.pm create mode 100644 cil/lib/TempFile.pm create mode 100644 cil/ocamlutil/Makefile.ocaml create mode 100644 cil/ocamlutil/Makefile.ocaml.build create mode 100755 cil/ocamlutil/alpha.ml create mode 100755 cil/ocamlutil/alpha.mli create mode 100644 cil/ocamlutil/clist.ml create mode 100644 cil/ocamlutil/clist.mli create mode 100644 cil/ocamlutil/errormsg.ml create mode 100644 cil/ocamlutil/errormsg.mli create mode 100644 cil/ocamlutil/growArray.ml create mode 100644 cil/ocamlutil/growArray.mli create mode 100755 cil/ocamlutil/inthash.ml create mode 100755 cil/ocamlutil/inthash.mli create mode 100755 cil/ocamlutil/intmap.ml create mode 100755 cil/ocamlutil/intmap.mli create mode 100755 cil/ocamlutil/perfcount.c.in create mode 100644 cil/ocamlutil/pretty.ml create mode 100644 cil/ocamlutil/pretty.mli create mode 100644 cil/ocamlutil/stats.ml create mode 100644 cil/ocamlutil/stats.mli create mode 100644 cil/ocamlutil/trace.ml create mode 100644 cil/ocamlutil/trace.mli create mode 100755 cil/ocamlutil/util.ml create mode 100644 cil/ocamlutil/util.mli create mode 100644 cil/src/check.ml create mode 100644 cil/src/check.mli create mode 100644 cil/src/cil.ml create mode 100644 cil/src/cil.mli create mode 100755 cil/src/cillower.ml create mode 100755 cil/src/cillower.mli create mode 100755 cil/src/ciloptions.ml create mode 100755 cil/src/ciloptions.mli create mode 100644 cil/src/cilutil.ml create mode 100644 cil/src/escape.ml create mode 100644 cil/src/escape.mli create mode 100644 cil/src/ext/astslicer.ml create mode 100644 cil/src/ext/availexps.ml create mode 100644 cil/src/ext/bitmap.ml create mode 100644 cil/src/ext/bitmap.mli create mode 100644 cil/src/ext/blockinggraph.ml create mode 100644 cil/src/ext/blockinggraph.mli create mode 100644 cil/src/ext/callgraph.ml create mode 100644 cil/src/ext/callgraph.mli create mode 100644 cil/src/ext/canonicalize.ml create mode 100644 cil/src/ext/canonicalize.mli create mode 100644 cil/src/ext/cfg.ml create mode 100644 cil/src/ext/cfg.mli create mode 100755 cil/src/ext/ciltools.ml create mode 100755 cil/src/ext/dataflow.ml create mode 100755 cil/src/ext/dataflow.mli create mode 100644 cil/src/ext/dataslicing.ml create mode 100644 cil/src/ext/dataslicing.mli create mode 100644 cil/src/ext/deadcodeelim.ml create mode 100755 cil/src/ext/dominators.ml create mode 100755 cil/src/ext/dominators.mli create mode 100644 cil/src/ext/epicenter.ml create mode 100644 cil/src/ext/heap.ml create mode 100644 cil/src/ext/heapify.ml create mode 100644 cil/src/ext/liveness.ml create mode 100644 cil/src/ext/logcalls.ml create mode 100644 cil/src/ext/logcalls.mli create mode 100644 cil/src/ext/logwrites.ml create mode 100644 cil/src/ext/oneret.ml create mode 100644 cil/src/ext/oneret.mli create mode 100644 cil/src/ext/partial.ml create mode 100644 cil/src/ext/pta/golf.ml create mode 100644 cil/src/ext/pta/golf.mli create mode 100644 cil/src/ext/pta/olf.ml create mode 100644 cil/src/ext/pta/olf.mli create mode 100644 cil/src/ext/pta/ptranal.ml create mode 100644 cil/src/ext/pta/ptranal.mli create mode 100644 cil/src/ext/pta/setp.ml create mode 100644 cil/src/ext/pta/setp.mli create mode 100644 cil/src/ext/pta/steensgaard.ml create mode 100644 cil/src/ext/pta/steensgaard.mli create mode 100644 cil/src/ext/pta/uref.ml create mode 100644 cil/src/ext/pta/uref.mli create mode 100644 cil/src/ext/reachingdefs.ml create mode 100755 cil/src/ext/sfi.ml create mode 100644 cil/src/ext/simplemem.ml create mode 100755 cil/src/ext/simplify.ml create mode 100644 cil/src/ext/ssa.ml create mode 100644 cil/src/ext/ssa.mli create mode 100644 cil/src/ext/stackoverflow.ml create mode 100644 cil/src/ext/stackoverflow.mli create mode 100755 cil/src/ext/usedef.ml create mode 100644 cil/src/formatcil.ml create mode 100644 cil/src/formatcil.mli create mode 100644 cil/src/formatlex.mll create mode 100644 cil/src/formatparse.mly create mode 100644 cil/src/frontc/cabs.ml create mode 100644 cil/src/frontc/cabs2cil.ml create mode 100644 cil/src/frontc/cabs2cil.mli create mode 100644 cil/src/frontc/cabsvisit.ml create mode 100644 cil/src/frontc/cabsvisit.mli create mode 100644 cil/src/frontc/clexer.mli create mode 100644 cil/src/frontc/clexer.mll create mode 100644 cil/src/frontc/cparser.mly create mode 100644 cil/src/frontc/cprint.ml create mode 100644 cil/src/frontc/frontc.ml create mode 100644 cil/src/frontc/frontc.mli create mode 100755 cil/src/frontc/lexerhack.ml create mode 100644 cil/src/frontc/patch.ml create mode 100644 cil/src/frontc/patch.mli create mode 100644 cil/src/libmaincil.ml create mode 100644 cil/src/machdep.c create mode 100644 cil/src/main.ml create mode 100644 cil/src/mergecil.ml create mode 100644 cil/src/mergecil.mli create mode 100644 cil/src/rmtmps.ml create mode 100644 cil/src/rmtmps.mli create mode 100644 cil/src/testcil.ml create mode 100644 cil/test/small1/func.c create mode 100644 cil/test/small1/hello.c create mode 100644 cil/test/small1/init.c create mode 100644 cil/test/small1/init1.c create mode 100644 cil/test/small1/testharness.h create mode 100644 cil/test/small1/vararg1.c create mode 100644 cil/test/small1/wchar1.c diff --git a/LICENSE b/LICENSE index 3626820..373ee65 100644 --- a/LICENSE +++ b/LICENSE @@ -37,14 +37,12 @@ files are free software and can be used both in commercial and non-commercial contexts, subject to the terms of the GNU General Public License. -This distribution includes a copy of the CIL library and modifications -to this library in the form of patches. The CIL library is Copyright -2001-2005 George C. Necula, Scott McPeak, Wes Weimer and Ben Liblit. -The modifications contained in the sub-directory cil.patches/ of this -distribution are Copyright 2006, 2007, 2008, 2009 Institut National de -Recherche en Informatique et en Automatique. The CIL library and the -modifications contained in the sub-directory cil.patches/ are -distributed under the terms of the BSD license, included below. +This distribution includes a modified copy of the CIL library. +The CIL library is Copyright 2001-2005 George C. Necula, Scott McPeak, +Wes Weimer and Ben Liblit. The modifications are Copyright 2006, +2007, 2008, 2009 Institut National de Recherche en Informatique et en +Automatique. The CIL library and the modifications are distributed +under the terms of the BSD license, included below. ---------------------------------------------------------------------- diff --git a/cil-1.3.5.tar.gz b/cil-1.3.5.tar.gz deleted file mode 100644 index 2c19144..0000000 Binary files a/cil-1.3.5.tar.gz and /dev/null differ diff --git a/cil.patch/Makefile.in.patch b/cil.patch/Makefile.in.patch deleted file mode 100644 index 7bc4ea1..0000000 --- a/cil.patch/Makefile.in.patch +++ /dev/null @@ -1,23 +0,0 @@ ---- ../cil/Makefile.in.orig 2008-12-31 19:08:43.000000000 +0100 -+++ ../cil/Makefile.in 2008-12-31 19:09:00.000000000 +0100 -@@ -212,7 +212,7 @@ - # build two libraries - .PHONY: cillib libcil - ifeq ($(NATIVECAML),1) --cillib: $(OBJDIR)/cil.$(CMXA) $(OBJDIR)/libcil.a -+cillib: $(OBJDIR)/cil.$(CMXA) # $(OBJDIR)/libcil.a - else - cillib: $(OBJDIR)/cil.$(CMXA) - endif -@@ -243,9 +243,9 @@ - echo " Zrapp.feature;" >> $@ - endif - # Now the extra features, with the first letter capitalized -- echo -ne \ -+ echo \ - $(foreach f,@EXTRAFEATURES@, \ -- `echo $f | cut -c 1 | tr "[a-z]" "[A-Z]"``echo $f | cut -c 2-`".feature;\n") >> $@ -+ `echo $f | cut -c 1 | tr "[a-z]" "[A-Z]"``echo $f | cut -c 2-`".feature;") >> $@ - echo "]" >>$@ - # Must delete main.d and remake it, because it may have been made - # before feature_config existed. diff --git a/cil.patch/astslicer.ml.patch b/cil.patch/astslicer.ml.patch deleted file mode 100644 index e8d0195..0000000 --- a/cil.patch/astslicer.ml.patch +++ /dev/null @@ -1,40 +0,0 @@ -*** ../cil/src/ext/astslicer.ml 2006-05-21 06:14:15.000000000 +0200 ---- ../cil_patch/src/ext/astslicer.ml 2006-06-20 17:24:22.000000000 +0200 -*************** -*** 1,3 **** ---- 1,5 ---- -+ (* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -+ - (* - * - * Copyright (c) 2001-2002, -*************** -*** 97,103 **** ---- 99,110 ---- - Printf.fprintf out ")\n" ; - incr i - | Switch(_,b,_,_) -+ (* - | Loop(b,_,_,_) -+ *) -+ | While(_,b,_) -+ | DoWhile(_,b,_) -+ | For(_,_,_,b,_) - | Block(b) -> - emit base i st_ht s ; - decr i ; -*************** -*** 371,377 **** ---- 378,389 ---- - doBlock b2 base'' i'' inside ; - incr i - | Switch(_,b,_,_) -+ (* - | Loop(b,_,_,_) -+ *) -+ | While(_,b,_) -+ | DoWhile(_,b,_) -+ | For(_,_,_,b,_) - | Block(b) -> - let inside = check base i default in - mark ws s inside ; diff --git a/cil.patch/cabs2cil.ml.patch b/cil.patch/cabs2cil.ml.patch deleted file mode 100644 index 74ae0c7..0000000 --- a/cil.patch/cabs2cil.ml.patch +++ /dev/null @@ -1,457 +0,0 @@ -*** ../cil.orig/src/frontc/cabs2cil.ml 2006-05-21 06:14:15.000000000 +0200 ---- ../cil/src/frontc/cabs2cil.ml 2008-04-19 10:17:27.000000000 +0200 -*************** -*** 1,3 **** ---- 1,11 ---- -+ (* MODIF: allow E.Error to propagate *) -+ -+ (* MODIF: for pointer comparison, avoid systematic cast to unsigned int *) -+ -+ (* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -+ (* MODIF: Return statement no longer added when the body of the function -+ falls-through. *) -+ - (* - * - * Copyright (c) 2001-2002, -*************** -*** 816,828 **** - (fun s -> - if s.labels != [] then - raise (Failure "cannot duplicate: has labels"); - (match s.skind with -! If _ | Switch _ | Loop _ | Block _ -> - raise (Failure "cannot duplicate: complex stmt") - | Instr il -> - pCount := !pCount + List.length il - | _ -> incr pCount); - if !pCount > 5 then raise (Failure ("cannot duplicate: too many instr")); - (* We can just copy it because there is nothing to share here. - * Except maybe for the ref cell in Goto but it is Ok to share - * that, I think *) ---- 824,839 ---- - (fun s -> - if s.labels != [] then - raise (Failure "cannot duplicate: has labels"); -+ (* - (match s.skind with -! If _ | Switch _ | (*Loop _*) -! While _ | DoWhile _ | For _ | Block _ -> - raise (Failure "cannot duplicate: complex stmt") - | Instr il -> - pCount := !pCount + List.length il - | _ -> incr pCount); - if !pCount > 5 then raise (Failure ("cannot duplicate: too many instr")); -+ *) - (* We can just copy it because there is nothing to share here. - * Except maybe for the ref cell in Goto but it is Ok to share - * that, I think *) -*************** -*** 838,843 **** ---- 849,855 ---- - let canDrop (c: chunk) = - List.for_all canDropStatement c.stmts - -+ (* - let loopChunk (body: chunk) : chunk = - (* Make the statement *) - let loop = mkStmt (Loop (c2block body, !currentLoc, None, None)) in -*************** -*** 845,850 **** ---- 857,889 ---- - postins = []; - cases = body.cases; - } -+ *) -+ -+ let whileChunk (e: exp) (body: chunk) : chunk = -+ let loop = mkStmt (While (e, c2block body, !currentLoc)) in -+ -+ { stmts = [ loop ]; -+ postins = []; -+ cases = body.cases; -+ } -+ -+ let doWhileChunk (e: exp) (body: chunk) : chunk = -+ let loop = mkStmt (DoWhile (e, c2block body, !currentLoc)) in -+ -+ { stmts = [ loop ]; -+ postins = []; -+ cases = body.cases; -+ } -+ -+ let forChunk (bInit: chunk) (e: exp) (bIter: chunk) -+ (body: chunk) : chunk = -+ let loop = mkStmt (For (c2block bInit, e, c2block bIter, -+ c2block body, !currentLoc)) in -+ -+ { stmts = [ loop ]; -+ postins = []; -+ cases = body.cases; -+ } - - let breakChunk (l: location) : chunk = - { stmts = [ mkStmt (Break l) ]; -*************** -*** 959,964 **** ---- 998,1004 ---- - - - (************ Labels ***********) -+ (* - (* Since we turn dowhile and for loops into while we need to take care in - * processing the continue statement. For each loop that we enter we place a - * marker in a list saying what kinds of loop it is. When we see a continue -*************** -*** 971,980 **** ---- 1011,1041 ---- - - let startLoop iswhile = - continues := (if iswhile then While else NotWhile (ref "")) :: !continues -+ *) -+ -+ (* We need to take care while processing the continue statement... -+ * For each loop that we enter we place a marker in a list saying what -+ * chunk of code we must duplicate before each continue statement -+ * in order to preserve the semantics. *) -+ type loopMarker = -+ | DuplicateBeforeContinue of chunk -+ | ContinueUnchanged -+ -+ let continues : loopMarker list ref = ref [] -+ -+ let startLoop lstate = -+ continues := lstate :: !continues -+ -+ let continueDuplicateChunk (l: location) : chunk = -+ match !continues with -+ | [] -> E.s (error "continue not in a loop") -+ | DuplicateBeforeContinue c :: _ -> c @@ continueChunk l -+ | ContinueUnchanged :: _ -> continueChunk l - - (* Sometimes we need to create new label names *) - let newLabelName (base: string) = fst (newAlphaName false "label" base) - -+ (* - let continueOrLabelChunk (l: location) : chunk = - match !continues with - [] -> E.s (error "continue not in a loop") -*************** -*** 990,995 **** ---- 1051,1057 ---- - [] -> E.s (error "labContinue not in a loop") - | While :: rest -> c - | NotWhile lr :: rest -> if !lr = "" then c else consLabel !lr c !currentLoc false -+ *) - - let exitLoop () = - match !continues with -*************** -*** 4141,4151 **** - | _ -> E.s (error "%a operator on a non-integer type" d_binop bop) - in - let pointerComparison e1 t1 e2 t2 = -! (* Cast both sides to an integer *) -! let commontype = !upointType in - intType, -! optConstFoldBinOp false bop (mkCastT e1 t1 commontype) -! (mkCastT e2 t2 commontype) intType - in - - match bop with ---- 4203,4211 ---- - | _ -> E.s (error "%a operator on a non-integer type" d_binop bop) - in - let pointerComparison e1 t1 e2 t2 = -! (* XL: Do not cast both sides -- what's the point? *) - intType, -! optConstFoldBinOp false bop e1 e2 intType - in - - match bop with -*************** -*** 4194,4207 **** - - | (Eq|Ne|Le|Lt|Ge|Gt) when isPointerType t1 && isArithmeticType t2 -> - ignore (warnOpt "Comparison of pointer and non-pointer"); -! (* Cast both values to upointType *) -! doBinOp bop (mkCastT e1 t1 !upointType) !upointType -! (mkCastT e2 t2 !upointType) !upointType - | (Eq|Ne|Le|Lt|Ge|Gt) when isArithmeticType t1 && isPointerType t2 -> - ignore (warnOpt "Comparison of pointer and non-pointer"); -! (* Cast both values to upointType *) -! doBinOp bop (mkCastT e1 t1 !upointType) !upointType -! (mkCastT e2 t2 !upointType) !upointType - - | _ -> E.s (error "doBinOp: %a\n" d_plainexp (BinOp(bop,e1,e2,intType))) - ---- 4254,4267 ---- - - | (Eq|Ne|Le|Lt|Ge|Gt) when isPointerType t1 && isArithmeticType t2 -> - ignore (warnOpt "Comparison of pointer and non-pointer"); -! (* Cast both values to void * *) -! doBinOp bop (mkCastT e1 t1 voidPtrType) voidPtrType -! (mkCastT e2 t2 voidPtrType) voidPtrType - | (Eq|Ne|Le|Lt|Ge|Gt) when isArithmeticType t1 && isPointerType t2 -> - ignore (warnOpt "Comparison of pointer and non-pointer"); -! (* Cast both values to void * *) -! doBinOp bop (mkCastT e1 t1 voidPtrType) voidPtrType -! (mkCastT e2 t2 voidPtrType) voidPtrType - - | _ -> E.s (error "doBinOp: %a\n" d_plainexp (BinOp(bop,e1,e2,intType))) - -*************** -*** 5465,5473 **** ---- 5525,5538 ---- - * then the switch falls through. *) - blockFallsThrough b || blockCanBreak b - end -+ (* - | Loop (b, _, _, _) -> - (* A loop falls through if it can break. *) - blockCanBreak b -+ *) -+ | While (_, b, _) -> blockCanBreak b -+ | DoWhile (_, b, _) -> blockCanBreak b -+ | For (_, _, _, b, _) -> blockCanBreak b - | Block b -> blockFallsThrough b - | TryFinally (b, h, _) -> blockFallsThrough h - | TryExcept (b, _, h, _) -> true (* Conservative *) -*************** -*** 5512,5518 **** - | Break _ -> true - | If (_, b1, b2, _) -> - blockCanBreak b1 || blockCanBreak b2 -! | Switch _ | Loop _ -> - (* switches and loops catch any breaks in their bodies *) - false - | Block b -> blockCanBreak b ---- 5577,5583 ---- - | Break _ -> true - | If (_, b1, b2, _) -> - blockCanBreak b1 || blockCanBreak b2 -! | Switch _ | (*Loop _*) While _ | DoWhile _ | For _ -> - (* switches and loops catch any breaks in their bodies *) - false - | Block b -> blockCanBreak b -*************** -*** 5522,5527 **** ---- 5587,5593 ---- - List.exists stmtCanBreak b.bstmts - in - if blockFallsThrough !currentFunctionFDEC.sbody then begin -+ (* - let retval = - match unrollType !currentReturnType with - TVoid _ -> None -*************** -*** 5537,5549 **** - !currentFunctionFDEC.sbody.bstmts <- - !currentFunctionFDEC.sbody.bstmts - @ [mkStmt (Return(retval, endloc))] - end; - - (* ignore (E.log "The env after finishing the body of %s:\n%t\n" - n docEnv); *) - cabsPushGlobal (GFun (!currentFunctionFDEC, funloc)); - empty -! with e -> begin - ignore (E.log "error in collectFunction %s: %s\n" - n (Printexc.to_string e)); - cabsPushGlobal (GAsm("error in function " ^ n, !currentLoc)); ---- 5603,5617 ---- - !currentFunctionFDEC.sbody.bstmts <- - !currentFunctionFDEC.sbody.bstmts - @ [mkStmt (Return(retval, endloc))] -+ *) - end; - - (* ignore (E.log "The env after finishing the body of %s:\n%t\n" - n docEnv); *) - cabsPushGlobal (GFun (!currentFunctionFDEC, funloc)); - empty -! with E.Error as e -> raise e -! | e -> begin - ignore (E.log "error in collectFunction %s: %s\n" - n (Printexc.to_string e)); - cabsPushGlobal (GAsm("error in function " ^ n, !currentLoc)); -*************** -*** 5596,5609 **** - * local context *) - addLocalToEnv (kindPlusName "type" n) (EnvTyp namedTyp); - cabsPushGlobal (GType (ti, !currentLoc)) -! with e -> begin - ignore (E.log "Error on A.TYPEDEF (%s)\n" - (Printexc.to_string e)); - cabsPushGlobal (GAsm ("booo_typedef:" ^ n, !currentLoc)) - end - in - List.iter createTypedef nl -! with e -> begin - ignore (E.log "Error on A.TYPEDEF (%s)\n" - (Printexc.to_string e)); - let fstname = ---- 5664,5679 ---- - * local context *) - addLocalToEnv (kindPlusName "type" n) (EnvTyp namedTyp); - cabsPushGlobal (GType (ti, !currentLoc)) -! with E.Error as e -> raise e -! | e -> begin - ignore (E.log "Error on A.TYPEDEF (%s)\n" - (Printexc.to_string e)); - cabsPushGlobal (GAsm ("booo_typedef:" ^ n, !currentLoc)) - end - in - List.iter createTypedef nl -! with E.Error as e -> raise e -! | e -> begin - ignore (E.log "Error on A.TYPEDEF (%s)\n" - (Printexc.to_string e)); - let fstname = -*************** -*** 5650,5656 **** - | _ -> - ignore (warn "Ignoring un-named typedef that does not introduce a struct or enumeration type\n") - -! with e -> begin - ignore (E.log "Error on A.ONLYTYPEDEF (%s)\n" - (Printexc.to_string e)); - cabsPushGlobal (GAsm ("booo_typedef", !currentLoc)) ---- 5720,5727 ---- - | _ -> - ignore (warn "Ignoring un-named typedef that does not introduce a struct or enumeration type\n") - -! with E.Error as e -> raise e -! | e -> begin - ignore (E.log "Error on A.ONLYTYPEDEF (%s)\n" - (Printexc.to_string e)); - cabsPushGlobal (GAsm ("booo_typedef", !currentLoc)) -*************** -*** 5738,5743 **** ---- 5809,5815 ---- - doCondition false e st' sf' - - | A.WHILE(e,s,loc) -> -+ (* - startLoop true; - let s' = doStatement s in - exitLoop (); -*************** -*** 5746,5753 **** ---- 5818,5844 ---- - loopChunk ((doCondition false e skipChunk - (breakChunk loc')) - @@ s') -+ *) -+ (** We need to convert A.WHILE(e,s) where e may have side effects -+ into Cil.While(e',s') where e' is side-effect free. *) -+ -+ (* Let e == (sCond , eCond) with sCond a sequence of statements -+ and eCond a side-effect free expression. *) -+ let (sCond, eCond, _) = doExp false e (AExp None) in -+ -+ (* Then doStatement(A.WHILE((sCond , eCond), s)) -+ = sCond ; Cil.While(eCond, (doStatement(s) ; sCond)) -+ where doStatement(A.CONTINUE) = (sCond ; Cil.Continue). *) -+ -+ startLoop (DuplicateBeforeContinue sCond); -+ let s' = doStatement s in -+ exitLoop (); -+ let loc' = convLoc loc in -+ currentLoc := loc'; -+ sCond @@ (whileChunk eCond (s' @@ sCond)) - - | A.DOWHILE(e,s,loc) -> -+ (* - startLoop false; - let s' = doStatement s in - let loc' = convLoc loc in -*************** -*** 5757,5764 **** - in - exitLoop (); - loopChunk (s' @@ s'') - -! | A.FOR(fc1,e2,e3,s,loc) -> begin - let loc' = convLoc loc in - currentLoc := loc'; - enterScope (); (* Just in case we have a declaration *) ---- 5848,5874 ---- - in - exitLoop (); - loopChunk (s' @@ s'') -+ *) -+ (** We need to convert A.DOWHILE(e,s) where e may have side effects -+ into Cil.DoWhile(e',s') where e' is side-effect free. *) -+ -+ (* Let e == (sCond , eCond) with sCond a sequence of statements -+ and eCond a side-effect free expression. *) -+ let (sCond, eCond, _) = doExp false e (AExp None) in -+ -+ (* Then doStatement(A.DOWHILE((sCond , eCond), s)) -+ = Cil.DoWhile(eCond, (doStatement(s) ; sCond)) -+ where doStatement(A.CONTINUE) = (sCond ; Cil.Continue). *) -+ -+ startLoop (DuplicateBeforeContinue sCond); -+ let s' = doStatement s in -+ exitLoop (); -+ let loc' = convLoc loc in -+ currentLoc := loc'; -+ doWhileChunk eCond (s' @@ sCond) - -! | A.FOR(fc1,e2,e3,s,loc) -> -! (*begin - let loc' = convLoc loc in - currentLoc := loc'; - enterScope (); (* Just in case we have a declaration *) -*************** -*** 5784,5789 **** ---- 5894,5928 ---- - exitScope (); - res - end -+ *) -+ (** We need to convert A.FOR(e1,e2,e3,s) where e1, e2 and e3 may -+ have side effects into Cil.For(bInit,e2',bIter,s') where e2' -+ is side-effect free. **) -+ -+ (* Let e1 == bInit be a block of statements -+ Let e2 == (bCond , eCond) with bCond a block of statements -+ and eCond a side-effect free expression -+ Let e3 == bIter be a sequence of statements. *) -+ let (bInit, _, _) = match fc1 with -+ | FC_EXP e1 -> doExp false e1 ADrop -+ | FC_DECL d1 -> (doDecl false d1, zero, voidType) in -+ let (bCond, eCond, _) = doExp false e2 (AExp None) in -+ let eCond' = match eCond with -+ | Const(CStr "exp_nothing") -> Cil.one -+ | _ -> eCond in -+ let (bIter, _, _) = doExp false e3 ADrop in -+ -+ (* Then doStatement(A.FOR(bInit, (bCond , eCond), bIter, s)) -+ = Cil.For({bInit; bCond}, eCond', {bIter; bCond}, {doStatement(s)}) -+ where doStatement(A.CONTINUE) = Cil.Continue. *) -+ -+ startLoop ContinueUnchanged; -+ let s' = doStatement s in -+ exitLoop (); -+ let loc' = convLoc loc in -+ currentLoc := loc'; -+ (forChunk (bInit @@ bCond) eCond' (bIter @@ bCond) s') -+ - | A.BREAK loc -> - let loc' = convLoc loc in - currentLoc := loc'; -*************** -*** 5792,5798 **** ---- 5931,5940 ---- - | A.CONTINUE loc -> - let loc' = convLoc loc in - currentLoc := loc'; -+ (* - continueOrLabelChunk loc' -+ *) -+ continueDuplicateChunk loc' - - | A.RETURN (A.NOTHING, loc) -> - let loc' = convLoc loc in diff --git a/cil.patch/cfg.ml.patch b/cil.patch/cfg.ml.patch deleted file mode 100644 index 9629d46..0000000 --- a/cil.patch/cfg.ml.patch +++ /dev/null @@ -1,55 +0,0 @@ -*** ../cil/src/ext/cfg.ml 2006-05-21 06:14:15.000000000 +0200 ---- ../cil_patch/src/ext/cfg.ml 2006-06-20 17:42:04.000000000 +0200 -*************** -*** 1,3 **** ---- 1,5 ---- -+ (* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -+ - (* - * - * Copyright (c) 2001-2003, -*************** -*** 156,162 **** ---- 158,169 ---- - then - addOptionSucc next; - cfgBlock blk next next cont -+ (* - | Loop(blk,_,_,_) -> -+ *) -+ | While(_,blk,_) -+ | DoWhile(_,blk,_) -+ | For(_,_,_,blk,_) -> - addBlockSucc blk; - cfgBlock blk (Some s) next (Some s) - (* Since all loops have terminating condition true, we don't put -*************** -*** 184,190 **** ---- 191,202 ---- - | Block b -> fasBlock todo b - | If (_, tb, fb, _) -> (fasBlock todo tb; fasBlock todo fb) - | Switch (_, b, _, _) -> fasBlock todo b -+ (* - | Loop (b, _, _, _) -> fasBlock todo b -+ *) -+ | While (_, b, _) -> fasBlock todo b -+ | DoWhile (_, b, _) -> fasBlock todo b -+ | For (_, _, _, b, _) -> fasBlock todo b - | (Return _ | Break _ | Continue _ | Goto _ | Instr _) -> () - | TryExcept _ | TryFinally _ -> E.s (E.unimp "try/except/finally") - end -*************** -*** 201,207 **** ---- 213,224 ---- - begin - match s.skind with - | If (e, _, _, _) -> "if" (*sprint ~width:999 (dprintf "if %a" d_exp e)*) -+ (* - | Loop _ -> "loop" -+ *) -+ | While _ -> "while" -+ | DoWhile _ -> "dowhile" -+ | For _ -> "for" - | Break _ -> "break" - | Continue _ -> "continue" - | Goto _ -> "goto" diff --git a/cil.patch/check.ml.patch b/cil.patch/check.ml.patch deleted file mode 100644 index 7fe183f..0000000 --- a/cil.patch/check.ml.patch +++ /dev/null @@ -1,56 +0,0 @@ -*** ../cil/src/check.ml 2006-05-21 06:14:15.000000000 +0200 ---- ../cil_patch/src/check.ml 2006-06-21 11:13:35.000000000 +0200 -*************** -*** 1,3 **** ---- 1,5 ---- -+ (* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -+ - (* - * - * Copyright (c) 2001-2002, -*************** -*** 661,667 **** - (fun _ -> - (* Print context only for certain small statements *) - match s.skind with -! Loop _ | If _ | Switch _ -> nil - | _ -> dprintf "checkStmt: %a" d_stmt s) - (fun _ -> - (* Check the labels *) ---- 663,669 ---- - (fun _ -> - (* Print context only for certain small statements *) - match s.skind with -! (*Loop _*) While _ | DoWhile _ | For _ | If _ | Switch _ -> nil - | _ -> dprintf "checkStmt: %a" d_stmt s) - (fun _ -> - (* Check the labels *) -*************** -*** 704,710 **** ---- 706,731 ---- - | None, _ -> ignore (warn "Invalid return value") - | Some re', rt' -> checkExpType false re' rt' - end -+ (* - | Loop (b, l, _, _) -> checkBlock b -+ *) -+ | While (e, b, l) -> -+ currentLoc := l; -+ let te = checkExp false e in -+ checkBooleanType te; -+ checkBlock b; -+ | DoWhile (e, b, l) -> -+ currentLoc := l; -+ let te = checkExp false e in -+ checkBooleanType te; -+ checkBlock b; -+ | For (bInit, e, bIter, b, l) -> -+ currentLoc := l; -+ checkBlock bInit; -+ let te = checkExp false e in -+ checkBooleanType te; -+ checkBlock bIter; -+ checkBlock b; - | Block b -> checkBlock b - | If (e, bt, bf, l) -> - currentLoc := l; diff --git a/cil.patch/cil.ml.patch b/cil.patch/cil.ml.patch deleted file mode 100644 index a49b73d..0000000 --- a/cil.patch/cil.ml.patch +++ /dev/null @@ -1,381 +0,0 @@ -*** ../cil/src/cil.ml 2006-05-21 06:14:15.000000000 +0200 ---- ../cil_patch/src/cil.ml 2006-07-25 10:57:30.686790845 +0200 -*************** -*** 1,3 **** ---- 1,6 ---- -+ (* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -+ (* MODIF: useLogicalOperators flag set to true by default. *) -+ - (* - * - * Copyright (c) 2001-2003, -*************** -*** 63,69 **** - * print output for the MS VC - * compiler. Default is GCC *) - -! let useLogicalOperators = ref false - - - module M = Machdep ---- 66,72 ---- - * print output for the MS VC - * compiler. Default is GCC *) - -! let useLogicalOperators = ref (*false*) true - - - module M = Machdep -*************** -*** 684,692 **** - | Goto of stmt ref * location (** A goto statement. Appears from - actual goto's in the code. *) - | Break of location (** A break to the end of the nearest -! enclosing Loop or Switch *) - | Continue of location (** A continue to the start of the -! nearest enclosing [Loop] *) - | If of exp * block * block * location (** A conditional. - Two successors, the "then" and - the "else" branches. Both ---- 687,695 ---- - | Goto of stmt ref * location (** A goto statement. Appears from - actual goto's in the code. *) - | Break of location (** A break to the end of the nearest -! enclosing loop or Switch *) - | Continue of location (** A continue to the start of the -! nearest enclosing loop *) - | If of exp * block * block * location (** A conditional. - Two successors, the "then" and - the "else" branches. Both -*************** -*** 701,706 **** ---- 704,710 ---- - you can get from the labels of the - statement *) - -+ (* - | Loop of block * location * (stmt option) * (stmt option) - (** A [while(1)] loop. The - * termination test is implemented -*************** -*** 713,718 **** ---- 717,726 ---- - * and the second will point to - * the stmt containing the break - * label for this loop. *) -+ *) -+ | While of exp * block * location (** A while loop. *) -+ | DoWhile of exp * block * location (** A do...while loop. *) -+ | For of block * exp * block * block * location (** A for loop. *) - - | Block of block (** Just a block of statements. Use it - as a way to keep some attributes -*************** -*** 1040,1046 **** ---- 1048,1059 ---- - | Continue(loc) -> loc - | If(_, _, _, loc) -> loc - | Switch (_, _, _, loc) -> loc -+ (* - | Loop (_, loc, _, _) -> loc -+ *) -+ | While (_, _, loc) -> loc -+ | DoWhile (_, _, loc) -> loc -+ | For (_, _, _, _, loc) -> loc - | Block b -> if b.bstmts == [] then lu - else get_stmtLoc ((List.hd b.bstmts).skind) - | TryFinally (_, _, l) -> l -*************** -*** 1524,1533 **** ---- 1537,1549 ---- - - let mkWhile ~(guard:exp) ~(body: stmt list) : stmt list = - (* Do it like this so that the pretty printer recognizes it *) -+ (* - [ mkStmt (Loop (mkBlock (mkStmt (If(guard, - mkBlock [ mkEmptyStmt () ], - mkBlock [ mkStmt (Break lu)], lu)) :: - body), lu, None, None)) ] -+ *) -+ [ mkStmt (While (guard, mkBlock body, lu)) ] - - - -*************** -*** 3448,3453 **** ---- 3464,3471 ---- - ++ self#pExp () e - ++ text ") " - ++ self#pBlock () b) -+ -+ (* - | Loop(b, l, _, _) -> begin - (* Maybe the first thing is a conditional. Turn it into a WHILE *) - try -*************** -*** 3484,3489 **** ---- 3502,3540 ---- - ++ text "ile (1) " - ++ self#pBlock () b) - end -+ *) -+ -+ | While (e, b, l) -> -+ self#pLineDirective l -+ ++ (align -+ ++ text "while (" -+ ++ self#pExp () e -+ ++ text ") " -+ ++ self#pBlock () b) -+ -+ | DoWhile (e, b, l) -> -+ self#pLineDirective l -+ ++ (align -+ ++ text "do " -+ ++ self#pBlock () b -+ ++ text " while (" -+ ++ self#pExp () e -+ ++ text ");") -+ -+ | For (bInit, e, bIter, b, l) -> -+ ignore (E.warn -+ "in for loops, the 1st and 3rd expressions are not printed"); -+ self#pLineDirective l -+ ++ (align -+ ++ text "for (" -+ ++ text "/* ??? */" (* self#pBlock () bInit *) -+ ++ text "; " -+ ++ self#pExp () e -+ ++ text "; " -+ ++ text "/* ??? */" (* self#pBlock() bIter *) -+ ++ text ") " -+ ++ self#pBlock () b) -+ - | Block b -> align ++ self#pBlock () b - - | TryFinally (b, h, l) -> -*************** -*** 4705,4713 **** ---- 4756,4781 ---- - | Return (Some e, l) -> - let e' = fExp e in - if e' != e then Return (Some e', l) else s.skind -+ (* - | Loop (b, l, s1, s2) -> - let b' = fBlock b in - if b' != b then Loop (b', l, s1, s2) else s.skind -+ *) -+ | While (e, b, l) -> -+ let e' = fExp e in -+ let b' = fBlock b in -+ if e' != e || b' != b then While (e', b', l) else s.skind -+ | DoWhile (e, b, l) -> -+ let b' = fBlock b in -+ let e' = fExp e in -+ if e' != e || b' != b then DoWhile (e', b', l) else s.skind -+ | For (bInit, e, bIter, b, l) -> -+ let bInit' = fBlock bInit in -+ let e' = fExp e in -+ let bIter' = fBlock bIter in -+ let b' = fBlock b in -+ if bInit' != bInit || e' != e || bIter' != bIter || b' != b then -+ For (bInit', e', bIter', b', l) else s.skind - | If(e, s1, s2, l) -> - let e' = fExp e in - (*if e queued any instructions, pop them here and remember them so that -*************** -*** 5180,5186 **** ---- 5248,5262 ---- - peepHole1 doone tb.bstmts; - peepHole1 doone eb.bstmts - | Switch (e, b, _, _) -> peepHole1 doone b.bstmts -+ (* - | Loop (b, l, _, _) -> peepHole1 doone b.bstmts -+ *) -+ | While (_, b, _) -> peepHole1 doone b.bstmts -+ | DoWhile (_, b, _) -> peepHole1 doone b.bstmts -+ | For (bInit, _, bIter, b, _) -> -+ peepHole1 doone bInit.bstmts; -+ peepHole1 doone bIter.bstmts; -+ peepHole1 doone b.bstmts - | Block b -> peepHole1 doone b.bstmts - | TryFinally (b, h, l) -> - peepHole1 doone b.bstmts; -*************** -*** 5214,5220 **** ---- 5290,5304 ---- - peepHole2 dotwo tb.bstmts; - peepHole2 dotwo eb.bstmts - | Switch (e, b, _, _) -> peepHole2 dotwo b.bstmts -+ (* - | Loop (b, l, _, _) -> peepHole2 dotwo b.bstmts -+ *) -+ | While (_, b, _) -> peepHole2 dotwo b.bstmts -+ | DoWhile (_, b, _) -> peepHole2 dotwo b.bstmts -+ | For (bInit, _, bIter, b, _) -> -+ peepHole2 dotwo bInit.bstmts; -+ peepHole2 dotwo bIter.bstmts; -+ peepHole2 dotwo b.bstmts - | Block b -> peepHole2 dotwo b.bstmts - | TryFinally (b, h, l) -> peepHole2 dotwo b.bstmts; - peepHole2 dotwo h.bstmts -*************** -*** 5887,5892 **** ---- 5971,5977 ---- - [] -> trylink s fallthrough - | hd :: tl -> (link s hd ; succpred_block b2 fallthrough )) - -+ (* - | Loop(b,l,_,_) -> - begin match b.bstmts with - [] -> failwith "computeCFGInfo: empty loop" -*************** -*** 5894,5899 **** ---- 5979,6011 ---- - link s hd ; - succpred_block b (Some(hd)) - end -+ *) -+ -+ | While (e, b, l) -> begin match b.bstmts with -+ | [] -> failwith "computeCFGInfo: empty loop" -+ | hd :: tl -> link s hd ; -+ succpred_block b (Some(hd)) -+ end -+ -+ | DoWhile (e, b, l) ->begin match b.bstmts with -+ | [] -> failwith "computeCFGInfo: empty loop" -+ | hd :: tl -> link s hd ; -+ succpred_block b (Some(hd)) -+ end -+ -+ | For (bInit, e, bIter, b, l) -> -+ (match bInit.bstmts with -+ | [] -> failwith "computeCFGInfo: empty loop" -+ | hd :: tl -> link s hd ; -+ succpred_block bInit (Some(hd))) ; -+ (match bIter.bstmts with -+ | [] -> failwith "computeCFGInfo: empty loop" -+ | hd :: tl -> link s hd ; -+ succpred_block bIter (Some(hd))) ; -+ (match b.bstmts with -+ | [] -> failwith "computeCFGInfo: empty loop" -+ | hd :: tl -> link s hd ; -+ succpred_block b (Some(hd))) ; - - | Block(b) -> begin match b.bstmts with - [] -> trylink s fallthrough -*************** -*** 5985,5991 **** - let i = get_switch_count () in - let break_stmt = mkStmt (Instr []) in - break_stmt.labels <- -! [Label((Printf.sprintf "switch_%d_break" i),l,false)] ; - let break_block = mkBlock [ break_stmt ] in - let body_block = b in - let body_if_stmtkind = (If(zero,body_block,break_block,l)) in ---- 6097,6103 ---- - let i = get_switch_count () in - let break_stmt = mkStmt (Instr []) in - break_stmt.labels <- -! [Label((Printf.sprintf "switch_%d_break" i),l,false)] ; - let break_block = mkBlock [ break_stmt ] in - let body_block = b in - let body_if_stmtkind = (If(zero,body_block,break_block,l)) in -*************** -*** 6026,6039 **** - s.skind <- handle_choices (List.sort compare_choices sl) ; - xform_switch_block b (fun () -> ref break_stmt) cont_dest i - end - | Loop(b,l,_,_) -> - let i = get_switch_count () in - let break_stmt = mkStmt (Instr []) in - break_stmt.labels <- -! [Label((Printf.sprintf "while_%d_break" i),l,false)] ; - let cont_stmt = mkStmt (Instr []) in - cont_stmt.labels <- -! [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; - b.bstmts <- cont_stmt :: b.bstmts ; - let this_stmt = mkStmt - (Loop(b,l,Some(cont_stmt),Some(break_stmt))) in ---- 6138,6152 ---- - s.skind <- handle_choices (List.sort compare_choices sl) ; - xform_switch_block b (fun () -> ref break_stmt) cont_dest i - end -+ (* - | Loop(b,l,_,_) -> - let i = get_switch_count () in - let break_stmt = mkStmt (Instr []) in - break_stmt.labels <- -! [Label((Printf.sprintf "while_%d_break" i),l,false)] ; - let cont_stmt = mkStmt (Instr []) in - cont_stmt.labels <- -! [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; - b.bstmts <- cont_stmt :: b.bstmts ; - let this_stmt = mkStmt - (Loop(b,l,Some(cont_stmt),Some(break_stmt))) in -*************** -*** 6043,6048 **** ---- 6156,6217 ---- - break_stmt.succs <- s.succs ; - let new_block = mkBlock [ this_stmt ; break_stmt ] in - s.skind <- Block new_block -+ *) -+ | While (e, b, l) -> -+ let i = get_switch_count () in -+ let break_stmt = mkStmt (Instr []) in -+ break_stmt.labels <- -+ [Label((Printf.sprintf "while_%d_break" i),l,false)] ; -+ let cont_stmt = mkStmt (Instr []) in -+ cont_stmt.labels <- -+ [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; -+ b.bstmts <- cont_stmt :: b.bstmts ; -+ let this_stmt = mkStmt -+ (While(e,b,l)) in -+ let break_dest () = ref break_stmt in -+ let cont_dest () = ref cont_stmt in -+ xform_switch_block b break_dest cont_dest label_index ; -+ break_stmt.succs <- s.succs ; -+ let new_block = mkBlock [ this_stmt ; break_stmt ] in -+ s.skind <- Block new_block -+ -+ | DoWhile (e, b, l) -> -+ let i = get_switch_count () in -+ let break_stmt = mkStmt (Instr []) in -+ break_stmt.labels <- -+ [Label((Printf.sprintf "while_%d_break" i),l,false)] ; -+ let cont_stmt = mkStmt (Instr []) in -+ cont_stmt.labels <- -+ [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; -+ b.bstmts <- cont_stmt :: b.bstmts ; -+ let this_stmt = mkStmt -+ (DoWhile(e,b,l)) in -+ let break_dest () = ref break_stmt in -+ let cont_dest () = ref cont_stmt in -+ xform_switch_block b break_dest cont_dest label_index ; -+ break_stmt.succs <- s.succs ; -+ let new_block = mkBlock [ this_stmt ; break_stmt ] in -+ s.skind <- Block new_block -+ -+ | For (bInit, e, bIter , b, l) -> -+ let i = get_switch_count () in -+ let break_stmt = mkStmt (Instr []) in -+ break_stmt.labels <- -+ [Label((Printf.sprintf "while_%d_break" i),l,false)] ; -+ let cont_stmt = mkStmt (Instr []) in -+ cont_stmt.labels <- -+ [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; -+ b.bstmts <- cont_stmt :: b.bstmts ; -+ let this_stmt = mkStmt -+ (For(bInit,e,bIter,b,l)) in -+ let break_dest () = ref break_stmt in -+ let cont_dest () = ref cont_stmt in -+ xform_switch_block b break_dest cont_dest label_index ; -+ break_stmt.succs <- s.succs ; -+ let new_block = mkBlock [ this_stmt ; break_stmt ] in -+ s.skind <- Block new_block -+ -+ - | Block(b) -> xform_switch_block b break_dest cont_dest label_index - - | TryExcept _ | TryFinally _ -> diff --git a/cil.patch/cil.mli.patch b/cil.patch/cil.mli.patch deleted file mode 100644 index d0e0363..0000000 --- a/cil.patch/cil.mli.patch +++ /dev/null @@ -1,59 +0,0 @@ -*** ../cil/src/cil.mli 2006-05-21 06:14:15.000000000 +0200 ---- ../cil_patch/src/cil.mli 2006-06-21 10:56:23.555126082 +0200 -*************** -*** 1,3 **** ---- 1,5 ---- -+ (* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -+ - (* - * - * Copyright (c) 2001-2002, -*************** -*** 918,927 **** - * statement. The target statement MUST have at least a label. *) - - | Break of location -! (** A break to the end of the nearest enclosing Loop or Switch *) - - | Continue of location -! (** A continue to the start of the nearest enclosing [Loop] *) - | If of exp * block * block * location - (** A conditional. Two successors, the "then" and the "else" branches. - * Both branches fall-through to the successor of the If statement. *) ---- 920,929 ---- - * statement. The target statement MUST have at least a label. *) - - | Break of location -! (** A break to the end of the nearest enclosing loop or Switch *) - - | Continue of location -! (** A continue to the start of the nearest enclosing loop *) - | If of exp * block * block * location - (** A conditional. Two successors, the "then" and the "else" branches. - * Both branches fall-through to the successor of the If statement. *) -*************** -*** 932,943 **** ---- 934,956 ---- - * among its labels what cases it implements. The statements that - * implement the cases are somewhere within the provided [block]. *) - -+ (* - | Loop of block * location * (stmt option) * (stmt option) - (** A [while(1)] loop. The termination test is implemented in the body of - * a loop using a [Break] statement. If prepareCFG has been called, - * the first stmt option will point to the stmt containing the continue - * label for this loop and the second will point to the stmt containing - * the break label for this loop. *) -+ *) -+ -+ | While of exp * block * location -+ (** A [while] loop. *) -+ -+ | DoWhile of exp * block * location -+ (** A [do...while] loop. *) -+ -+ | For of block * exp * block * block * location -+ (** A [for] loop. *) - - | Block of block - (** Just a block of statements. Use it as a way to keep some block diff --git a/cil.patch/clexer.mll.patch b/cil.patch/clexer.mll.patch deleted file mode 100644 index edbe8be..0000000 --- a/cil.patch/clexer.mll.patch +++ /dev/null @@ -1,24 +0,0 @@ -*** ../cil.orig/src/frontc/clexer.mll 2006-05-21 06:14:15.000000000 +0200 ---- ../cil/src/frontc/clexer.mll 2009-03-29 10:34:34.000000000 +0200 -*************** -*** 584,590 **** - | blank { hash lexbuf} - | intnum { (* We are seeing a line number. This is the number for the - * next line *) -! E.setCurrentLine (int_of_string (Lexing.lexeme lexbuf) - 1); - (* A file name must follow *) - file lexbuf } - | "line" { hash lexbuf } (* MSVC line number info *) ---- 584,595 ---- - | blank { hash lexbuf} - | intnum { (* We are seeing a line number. This is the number for the - * next line *) -! let s = Lexing.lexeme lexbuf in -! begin try -! E.setCurrentLine (int_of_string s - 1) -! with Failure _ -> -! E.warn "Bad line number in preprocessed file: %s" s -! end; - (* A file name must follow *) - file lexbuf } - | "line" { hash lexbuf } (* MSVC line number info *) diff --git a/cil.patch/dataflow.ml.patch b/cil.patch/dataflow.ml.patch deleted file mode 100644 index 87b00de..0000000 --- a/cil.patch/dataflow.ml.patch +++ /dev/null @@ -1,27 +0,0 @@ -*** ../cil/src/ext/dataflow.ml 2006-05-21 06:14:15.000000000 +0200 ---- ../cil_patch/src/ext/dataflow.ml 2006-06-20 17:28:35.000000000 +0200 -*************** -*** 1,3 **** ---- 1,4 ---- -+ (* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) - - module IH = Inthash - module E = Errormsg -*************** -*** 219,225 **** - - | Goto _ | Break _ | Continue _ | If _ - | TryExcept _ | TryFinally _ -! | Switch _ | Loop _ | Return _ | Block _ -> curr - in - currentLoc := get_stmtLoc s.skind; - ---- 220,227 ---- - - | Goto _ | Break _ | Continue _ | If _ - | TryExcept _ | TryFinally _ -! | Switch _ | (*Loop _*) While _ | DoWhile _ | For _ -! | Return _ | Block _ -> curr - in - currentLoc := get_stmtLoc s.skind; - diff --git a/cil.patch/dataslicing.ml.patch b/cil.patch/dataslicing.ml.patch deleted file mode 100644 index cebf2e3..0000000 --- a/cil.patch/dataslicing.ml.patch +++ /dev/null @@ -1,28 +0,0 @@ -*** ../cil/src/ext/dataslicing.ml 2006-05-21 06:14:15.000000000 +0200 ---- ../cil_patch/src/ext/dataslicing.ml 2006-06-21 11:14:58.866051623 +0200 -*************** -*** 1,3 **** ---- 1,5 ---- -+ (* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -+ - (* - * - * Copyright (c) 2004, -*************** -*** 357,365 **** ---- 359,373 ---- - | Return (eo, l) -> sliceReturnExp eo l - | Switch (e, b, sl, l) -> Switch (sliceExp 1 e, sliceBlock b, - List.map sliceStmt sl, l) -+ (* - | Loop (b, l, so1, so2) -> Loop (sliceBlock b, l, - applyOption sliceStmt so1, - applyOption sliceStmt so2) -+ *) -+ | While (e, b, l) -> While (sliceExp 1 e, sliceBlock b, l) -+ | DoWhile (e, b, l) -> DoWhile (sliceExp 1 e, sliceBlock b, l) -+ | For (bInit, e, bIter, b, l) -> -+ For (sliceBlock bInit, sliceExp 1e, sliceBlock bIter, sliceBlock b, l) - | Goto _ -> sk - | _ -> E.s (unimp "statement") - diff --git a/cil.patch/formatparse.mly.patch b/cil.patch/formatparse.mly.patch deleted file mode 100644 index 09e161b..0000000 --- a/cil.patch/formatparse.mly.patch +++ /dev/null @@ -1,40 +0,0 @@ -*** ../cil/src/formatparse.mly 2006-05-21 06:14:15.000000000 +0200 ---- ../cil_patch/src/formatparse.mly 2006-06-20 16:22:57.000000000 +0200 -*************** -*** 1,3 **** ---- 1,5 ---- -+ /* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. */ -+ - /*(* Parser for constructing CIL from format strings *) - (* - * -*************** -*** 1352,1357 **** ---- 1354,1360 ---- - mkCast e !upointType - else e - in -+ (* - mkStmt - (Loop (mkBlock [ mkStmt - (If(e, -*************** -*** 1360,1366 **** - (Break loc) ], - loc)); - $5 mkTemp loc args ], -! loc, None, None))) - } - | instr_list { (fun mkTemp loc args -> - mkStmt (Instr ($1 loc args))) ---- 1363,1372 ---- - (Break loc) ], - loc)); - $5 mkTemp loc args ], -! loc, None, None)) -! *) -! mkStmt -! (While (e, mkBlock [ $5 mkTemp loc args ], loc))) - } - | instr_list { (fun mkTemp loc args -> - mkStmt (Instr ($1 loc args))) diff --git a/cil.patch/mergecil.ml.patch b/cil.patch/mergecil.ml.patch deleted file mode 100644 index cc976ec..0000000 --- a/cil.patch/mergecil.ml.patch +++ /dev/null @@ -1,25 +0,0 @@ -*** ../cil/src/mergecil.ml 2006-05-21 06:14:15.000000000 +0200 ---- ../cil_patch/src/mergecil.ml 2006-06-20 17:20:05.000000000 +0200 -*************** -*** 1,3 **** ---- 1,5 ---- -+ (* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -+ - (* - * - * Copyright (c) 2001-2002, -*************** -*** 1151,1157 **** ---- 1153,1164 ---- - + 41*(stmtListSum b2.bstmts) - | Switch(_,b,_,_) -> 43 + 47*(stmtListSum b.bstmts) - (* don't look at stmt list b/c is not part of tree *) -+ (* - | Loop(b,_,_,_) -> 49 + 53*(stmtListSum b.bstmts) -+ *) -+ | While(_,b,_) -> 49 + 53*(stmtListSum b.bstmts) -+ | DoWhile(_,b,_) -> 49 + 53*(stmtListSum b.bstmts) -+ | For(_,_,_,b,_) -> 49 + 53*(stmtListSum b.bstmts) - | Block(b) -> 59 + 61*(stmtListSum b.bstmts) - | TryExcept (b, (il, e), h, _) -> - 67 + 83*(stmtListSum b.bstmts) + 97*(stmtListSum h.bstmts) diff --git a/cil.patch/oneret.ml.patch b/cil.patch/oneret.ml.patch deleted file mode 100644 index d4c13d5..0000000 --- a/cil.patch/oneret.ml.patch +++ /dev/null @@ -1,38 +0,0 @@ -*** ../cil/src/ext/oneret.ml 2006-05-21 06:14:15.000000000 +0200 ---- ../cil_patch/src/ext/oneret.ml 2006-06-21 11:15:54.000000000 +0200 -*************** -*** 1,3 **** ---- 1,5 ---- -+ (* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -+ - (* - * - * Copyright (c) 2001-2002, -*************** -*** 133,142 **** ---- 135,159 ---- - currentLoc := l; - s.skind <- If(eb, scanBlock false t, scanBlock false e, l); - s :: scanStmts mainbody rests -+ (* - | ({skind=Loop(b,l,lb1,lb2)} as s) :: rests -> - currentLoc := l; - s.skind <- Loop(scanBlock false b, l,lb1,lb2); - s :: scanStmts mainbody rests -+ *) -+ | ({skind=While(e,b,l)} as s) :: rests -> -+ currentLoc := l; -+ s.skind <- While(e, scanBlock false b, l); -+ s :: scanStmts mainbody rests -+ | ({skind=DoWhile(e,b,l)} as s) :: rests -> -+ currentLoc := l; -+ s.skind <- DoWhile(e, scanBlock false b, l); -+ s :: scanStmts mainbody rests -+ | ({skind=For(bInit,e,bIter,b,l)} as s) :: rests -> -+ currentLoc := l; -+ s.skind <- For(scanBlock false bInit, e, scanBlock false bIter, -+ scanBlock false b, l); -+ s :: scanStmts mainbody rests - | ({skind=Switch(e, b, cases, l)} as s) :: rests -> - currentLoc := l; - s.skind <- Switch(e, scanBlock false b, cases, l); diff --git a/cil.patch/ptranal.ml.patch b/cil.patch/ptranal.ml.patch deleted file mode 100644 index 8b5cf9f..0000000 --- a/cil.patch/ptranal.ml.patch +++ /dev/null @@ -1,28 +0,0 @@ -*** ../cil/src/ext/pta/ptranal.ml 2006-05-21 06:14:15.000000000 +0200 ---- ../cil_patch/src/ext/pta/ptranal.ml 2006-06-21 11:55:25.414890423 +0200 -*************** -*** 1,3 **** ---- 1,5 ---- -+ (* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -+ - (* - * - * Copyright (c) 2001-2002, -*************** -*** 312,318 **** ---- 314,328 ---- - | Switch (e, b, sl, l) -> - analyze_block b; - List.iter analyze_stmt sl -+ (* - | Loop (b, l, _, _) -> analyze_block b -+ *) -+ | While (_, b, _) -> analyze_block b -+ | DoWhile (_, b, _) -> analyze_block b -+ | For (bInit, _, bIter, b, _) -> -+ analyze_block bInit; -+ analyze_block bIter; -+ analyze_block b - | Block b -> analyze_block b - | TryFinally (b, h, _) -> - analyze_block b; diff --git a/cil.patch/usedef.ml.patch b/cil.patch/usedef.ml.patch deleted file mode 100644 index d075316..0000000 --- a/cil.patch/usedef.ml.patch +++ /dev/null @@ -1,38 +0,0 @@ -*** ../cil/src/ext/usedef.ml 2006-05-21 06:14:15.000000000 +0200 ---- ../cil_patch/src/ext/usedef.ml 2006-06-20 17:36:16.000000000 +0200 -*************** -*** 1,3 **** ---- 1,5 ---- -+ (* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) -+ - - open Cil - open Pretty -*************** -*** 130,136 **** ---- 132,141 ---- - | Return (Some e, _) -> ve e - | If (e, _, _, _) -> ve e - | Break _ | Goto _ | Continue _ -> () -+ (* - | Loop (_, _, _, _) -> () -+ *) -+ | While _ | DoWhile _ | For _ -> () - | Switch (e, _, _, _) -> ve e - | Instr il -> - List.iter (fun i -> ignore (visitCilInstr useDefVisitor i)) il -*************** -*** 165,171 **** ---- 170,181 ---- - let u'', d'' = handle_block fb in - (VS.union (VS.union u u') u'', VS.union (VS.union d d') d'') - | Break _ | Goto _ | Continue _ -> !varUsed, !varDefs -+ (* - | Loop (b, _, _, _) -> handle_block b -+ *) -+ | While (_, b, _) -> handle_block b -+ | DoWhile (_, b, _) -> handle_block b -+ | For (_, _, _, b, _) -> handle_block b - | Switch (e, b, _, _) -> - let _ = ve e in - let u, d = !varUsed, !varDefs in diff --git a/cil/INSTALL b/cil/INSTALL new file mode 100644 index 0000000..ef7846f --- /dev/null +++ b/cil/INSTALL @@ -0,0 +1,41 @@ + + (For more complete installation instructions see the documentation in + doc/html.) + + Building from source (see below for installing binary distributions) +--------------------------------------------------------------------- + + 1. If you use Windows, you must first install cygwin. + + 2. You must install OCaml version 3.08 or higher (see instructions at + http://caml.inria.fr/ocaml). The recommended build process is using + the cygwin version of ocaml. + + You can also build with Microsoft Visual Studio, but you must still have + cygwin during the build process. See msvcbuild.cmd. + + 3. Download and unpack the distribution. + + 4. Run ./configure (from within bash if on Windows) + + 5. Run make + + 6. Run make check + + Now you can start using bin/cilly and bin/ccured as explained in the + documentation (in doc/html). + + + Installing binary distributions (Windows-only) +----------------------------------------------- + + 1. Unpack the installation package + + 2. Change CILHOME to the full path of the diretory where you put cil, in + the following files: bin/CilConfig.pm, bin/cilly.bat, bin/patcher.bat + 3. Go to test/small1 directory and run + ..\..\cilly /c hello.c + + + + \ No newline at end of file diff --git a/cil/LICENSE b/cil/LICENSE new file mode 100644 index 0000000..5a7dab5 --- /dev/null +++ b/cil/LICENSE @@ -0,0 +1,35 @@ +Copyright (c) 2001-2005, + George C. Necula + Scott McPeak + Wes Weimer + Ben Liblit +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution. + +3. The names of the contributors may not be used to endorse or promote +products derived from this software without specific prior written +permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. + + +(See http://www.opensource.org/licenses/bsd-license.php) diff --git a/cil/Makefile.gcc b/cil/Makefile.gcc new file mode 100644 index 0000000..8fae4e3 --- /dev/null +++ b/cil/Makefile.gcc @@ -0,0 +1,75 @@ +# -*-makefile-*- +# Makefile for CCured. The gcc part + + +COMPILERNAME := GNUCC + +CC := gcc +ifdef RELEASELIB + # sm: I will leave this here, but only use it for compiling our runtime lib + CFLAGS := -D_GNUCC -Wall -O3 +else + CFLAGS := -D_GNUCC -Wall -g -ggdb -D_DEBUG +endif + +# dsw: added optional -pg flag +ifdef USE_PG + CFLAGS += -pg +endif + +ifdef NO_OPTIMIZATION + OPT_O2 := +else + OPT_O2 := -O2 +endif +CONLY := -c +OBJOUT := -o +OBJEXT := o +LIBEXT := a +EXEOUT := -o +LDEXT := +DEF := -D +ASMONLY := -S -o +WARNALL := -Wall +# sm: shuffled around a couple things so I could use CPPSTART for patch2 +CPPSTART := gcc -E -x c -Dx86_LINUX -D_GNUCC -I/usr/include/sys +CPPOUT := -o %o +CPP := $(CPPSTART) -include fixup.h %i $(CPPOUT) +INC := -I + +# sm: disable patching for now ('true' has no output) +# (set it to 'echo' to re-enable) +ifndef PATCHECHO + PATCHECHO := echo +endif + +AR := ar +LIBOUT := -rs + +# The system include files to be patched +PATCH_SYSINCLUDES := crypt.h ctype.h fcntl.h glob.h grp.h malloc.h netdb.h \ + pthread.h pwd.h signal.h stdarg.h stdio.h stdlib.h \ + string.h time.h unistd.h varargs.h arpa/inet.h \ + sys/cdefs.h sys/fcntl.h sys/ioctl.h sys/socket.h \ + sys/stat.h sys/types.h sys/uio.h malloc.h setjmp.h + +ifneq ($(ARCHOS), x86_WIN32) +PATCH_SYSINCLUDES += sys/shm.h +endif + +# dsw & sm: DON'T DO THIS. See comment in ccured_GNUCC.patch, search for 'sys/io.h'. +# PATCH_SYSINCLUDES += sys/io.h + +# matth: reent.h is only in Cygwin, and Cygwin defines struct sigaction +# in sys/signal.h: +ifeq ($(ARCHOS), x86_WIN32) +PATCH_SYSINCLUDES += sys/reent.h sys/signal.h +endif + +# matth: these files are not in Cygwin +ifeq ($(ARCHOS), x86_LINUX) +PATCH_SYSINCLUDES += nl_types.h bits/sigaction.h bits/select.h sys/prctl.h \ + libgen.h shadow.h +endif + + diff --git a/cil/Makefile.in b/cil/Makefile.in new file mode 100644 index 0000000..a16d60c --- /dev/null +++ b/cil/Makefile.in @@ -0,0 +1,656 @@ +# -*- Mode: makefile -*- + +# Makefile for the cil wrapper +# @do_not_edit@ Makefile.in +# +# author: George Necula + +# +# If you want to add extra CIL features, you do not always need to change +# this file. Just invoke +# ./configure EXTRASRCDIRS=/home/foodir EXTRAFEATURES="foo bar" +# This will add two features that must be defined in foo.ml and bar.ml +# + +# Debugging. Set ECHO= to debug this Makefile +.PHONY: setup quickbuild doc distrib machdep cilversion +ECHO = @ + +# It is important to build quickbuild first, to generate the proper dependencies +all: quickbuild setup + +# Now add the defines for the CIL features +@CIL_FEATURES_DEFINES@ + + +# look out for outdated Makefile; if it's out of date, this will automatically +# re-run ./config.status, then re-exec make with the same arguments +Makefile: config.status Makefile.in + ./$< + +config.status: configure + ./$@ --recheck + +configure: configure.in + autoconf + +ocamlutil/perfcount.c: config.status ocamlutil/perfcount.c.in + ./$< + +@DEFAULT_COMPILER@=1 + + + +ifdef RELEASE + NATIVECAML := 1 + UNSAFE := 1 +endif + +ifndef ARCHOS + ARCHOS=@ARCHOS@ +endif + +# Put here all the byproducts of make +OBJDIR := obj/$(ARCHOS) +DEPENDDIR := obj/.depend + +CILLY_FEATURES := +ifdef USE_BLOCKINGGRAPH + CILLY_FEATURES += blockinggraph +endif +ifdef USE_RAND + CILLY_FEATURES += rand +endif +ifdef USE_ARITHABS + CILLY_FEATURES += arithabs +endif +ifdef USE_SMALLOC + CILLY_FEATURES += smalloc +endif +ifdef USE_CQUALANN + CILLY_FEATURES += cqualann +endif +ifdef USE_ZRAPP + CILLY_FEATURES += rmciltmps zrapp +endif +# Add the EXTRAFEATURES +CILLY_FEATURES += @EXTRAFEATURES@ + + # Now rules to make cilly +CILLY_LIBRARY_MODULES = pretty inthash errormsg alpha trace stats util clist \ + cilutil escape growArray\ + cabs cabsvisit cprint lexerhack machdep cparser clexer \ + cilversion cil cillower formatparse formatlex formatcil cabs2cil \ + patch frontc check mergecil \ + dataflow dominators bitmap ssa ciltools \ + usedef logcalls logwrites rmtmps \ + callgraph epicenter heapify \ + setp uref olf ptranal \ + canonicalize heap oneret partial simplemem simplify \ + dataslicing sfi \ + cfg reachingdefs deadcodeelim availexps \ + liveness \ + testcil \ + $(CILLY_FEATURES) \ + ciloptions feature_config +# ww: we don't want "main" in an external cil library (cil.cma), +# otherwise every program that links against that library will get +# main's argument checking and whatnot ... +CILLY_MODULES = $(CILLY_LIBRARY_MODULES) main +CILLY_CMODULES = +CILLY_LIBS = unix str + +SOURCEDIRS += src src/frontc src/ext src/ext/pta ocamlutil @EXTRASRCDIRS@ +MLLS += clexer.mll formatlex.mll +MLYS += cparser.mly formatparse.mly +MODULES += $(CILLY_MODULES) libmaincil + + + + # Include now the common set of rules for OCAML +include ocamlutil/Makefile.ocaml + + + # Now the rule to make cilly + +PROJECT_EXECUTABLE = $(OBJDIR)/cilly$(EXE) +PROJECT_MODULES = $(CILLY_MODULES) +PROJECT_CMODULES = perfcount $(CILLY_CMODULES) +PROJECT_LIBS = $(CILLY_LIBS) +cilly: $(PROJECT_EXECUTABLE) +include ocamlutil/Makefile.ocaml.build + + +quickbuild: cilversion machdep cilly + +# Setup also makes the native code versions +# +# sm: cillib is only built with NATIVECAML=1 because it builds libcil.a, +# which requires native-code .cmx compiled modules... could break it +# into two targets so we build cil.cma both ways, but no one is using +# cil.cma now so I'll leave it alone +setup: cilversion machdep + $(MAKE) cilly NATIVECAML= + $(MAKE) cilly NATIVECAML=1 + $(MAKE) cillib NATIVECAML= + $(MAKE) cillib NATIVECAML=1 + +# Create the machine dependency module +# If the cl command cannot be run then the MSVC part will be identical to GCC +.PHONY : machdep +machdep: $(OBJDIR)/machdep.ml +$(OBJDIR)/machdep.ml : src/machdep.c configure.in Makefile.in + rm -f $@ + echo "(* This module was generated automatically by code in Makefile and machdep.c *)" >$@ +# Now generate the type definition + echo "type mach = {" >> $@ + echo " version_major: int; (* Major version number *)" >> $@ + echo " version_minor: int; (* Minor version number *)" >> $@ + echo " version: string; (* version number *)" >> $@ + echo " underscore_name: bool; (* If assembly names have leading underscore *)" >> $@ + echo " sizeof_short: int; (* Size of \"short\" *)" >> $@ + echo " sizeof_int: int; (* Size of \"int\" *)" >> $@ + echo " sizeof_long: int ; (* Size of \"long\" *)" >> $@ + echo " sizeof_longlong: int; (* Size of \"long long\" *)" >> $@ + echo " sizeof_ptr: int; (* Size of pointers *)" >> $@ + echo " sizeof_enum: int; (* Size of enum types *)" >> $@ + echo " sizeof_float: int; (* Size of \"float\" *)" >> $@ + echo " sizeof_double: int; (* Size of \"double\" *)" >> $@ + echo " sizeof_longdouble: int; (* Size of \"long double\" *)" >> $@ + echo " sizeof_sizeof: int; (* Size of \"sizeof(T)\" *)" >> $@ + echo " sizeof_wchar: int; (* Size of \"wchar_t\" *)" >> $@ + echo " sizeof_void: int; (* Size of \"void\" *)" >> $@ + echo " sizeof_fun: int; (* Size of function *)" >> $@ + echo " alignof_short: int; (* Alignment of \"short\" *)" >> $@ + echo " alignof_int: int; (* Alignment of \"int\" *)" >> $@ + echo " alignof_long: int; (* Alignment of \"long\" *)" >> $@ + echo " alignof_longlong: int; (* Alignment of \"long long\" *)" >> $@ + echo " alignof_ptr: int; (* Alignment of pointers *)" >> $@ + echo " alignof_enum: int; (* Alignment of enum types *)" >> $@ + echo " alignof_float: int; (* Alignment of \"float\" *)" >> $@ + echo " alignof_double: int; (* Alignment of \"double\" *)" >> $@ + echo " alignof_longdouble: int; (* Alignment of \"long double\" *)" >> $@ + echo " alignof_str: int; (* Alignment of strings *)" >> $@ + echo " alignof_fun: int; (* Alignment of function *)" >> $@ + echo " char_is_unsigned: bool; (* Whether \"char\" is unsigned *)">> $@ + echo " const_string_literals: bool; (* Whether string literals have const chars *)">> $@ + echo " little_endian: bool; (* whether the machine is little endian *)">>$@ + echo "}" >> $@ + if gcc -D_GNUCC $< -o $(OBJDIR)/machdep.exe ;then \ + echo "machdep.exe created succesfull." \ + ;else \ + rm -f $@; exit 1 \ + ;fi + echo "let gcc = {" >>$@ + $(OBJDIR)/machdep.exe >>$@ + echo " underscore_name = @UNDERSCORE_NAME@ ;" >> $@ + echo "}" >>$@ + if cl /D_MSVC $< /Fe$(OBJDIR)/machdep.exe /Fo$(OBJDIR)/machdep.obj ;then \ + echo "let hasMSVC = true" >>$@ \ + ;else \ + echo "let hasMSVC = false" >>$@ ;fi + echo "let msvc = {" >>$@ + $(OBJDIR)/machdep.exe >>$@ + echo " underscore_name = true ;" >> $@ + echo "}" >>$@ + echo "let gccHas__builtin_va_list = @HAVE_BUILTIN_VA_LIST@" >>$@ + echo "let __thread_is_keyword = @THREAD_IS_KEYWORD@" >>$@ + +# +# Create the version information module +.PHONY: cilversion +cilversion: $(OBJDIR)/cilversion.ml +$(OBJDIR)/cilversion.ml: configure.in Makefile.in + rm -f $@ + echo "(* This module was generated automatically by code in Makefile *)" >$@ +# Generate here the version information + echo "let cilVersionMajor = @CIL_VERSION_MAJOR@" >>$@ + echo "let cilVersionMinor = @CIL_VERSION_MINOR@" >>$@ + echo "let cilVersionRev = @CIL_VERSION_REV@" >>$@ + echo "let cilVersion = \"@CIL_VERSION@\"" >>$@ + +# build two libraries +.PHONY: cillib libcil +ifeq ($(NATIVECAML),1) +cillib: $(OBJDIR)/cil.$(CMXA) # $(OBJDIR)/libcil.a +else +cillib: $(OBJDIR)/cil.$(CMXA) +endif + + +$(OBJDIR)/feature_config.ml: Makefile config.status + rm -f $(OBJDIR)/feature_config.* + echo "(* This module was generated automatically by code in Makefile.in *)" >$@ +# The Cilly feature options. A list of Cil.featureDescr + echo "open Cil" >>$@ + echo "let features : featureDescr list = [" >> $@ +ifdef USE_BLOCKINGGRAPH + echo " Blockinggraph.feature;" >> $@ +endif +ifdef USE_RAND + echo " Rand.feature;" >> $@ +endif +ifdef USE_ARITHABS + echo " Arithabs.feature;" >>$@ +endif +ifdef USE_SMALLOC + echo " Smalloc.feature;" >> $@ +endif +ifdef USE_CQUALANN + echo " Cqualann.feature;" >> $@ +endif +ifdef USE_ZRAPP + echo " Zrapp.feature;" >> $@ +endif +# Now the extra features, with the first letter capitalized + echo \ + $(foreach f,@EXTRAFEATURES@, \ + `echo $f | cut -c 1 | tr "[a-z]" "[A-Z]"``echo $f | cut -c 2-`".feature;") >> $@ + echo "]" >>$@ +# Must delete main.d and remake it, because it may have been made +# before feature_config existed. + rm -f $(DEPENDDIR)/main.d + $(MAKE) $(DEPENDDIR)/main.d + + + + + + +OCAML_CIL_LIB_MODULES := $(CILLY_LIBRARY_MODULES) +OCAML_CIL_LIB_CMODULES := perfcount + +# list of modules to use for building a library; remove 'main' +# and add 'libmaincil' +OCAML_CIL_C_LIB_MODULES := $(CILLY_MODULES:main=) libmaincil + +# Build an OCAML library (CMA / CMXA) that exports our Cil stuff +$(OBJDIR)/cil.$(CMXA): $(OCAML_CIL_LIB_CMODULES:%=$(OBJDIR)/lib%.a) \ + $(OCAML_CIL_LIB_MODULES:%=$(OBJDIR)/%.$(CMO)) + $(CAMLLINK) -a -o $@ -ccopt -L$(pkglibdir) \ + $(OCAML_CIL_LIB_CMODULES:%=-cclib -l%) \ + $(OCAML_CIL_LIB_MODULES:%=$(OBJDIR)/%.$(CMO)) + +$(OBJDIR)/libperfcount.a: %: %($(OBJDIR)/perfcount.$(CMC)) + ranlib $@ + +# sm: for Simon: build a library of CIL functions which can +# be called from C code; this is like the target above, except +# it is callable from C instead of from Ocaml +ifeq ($(NATIVECAML),1) +$(OBJDIR)/libcil.a: $(OCAML_CIL_LIB_CMODULES:%=$(OBJDIR)/lib%.a) \ + $(OCAML_CIL_LIB_MODULES:%=$(OBJDIR)/%.$(CMO)) + ocamlopt -output-obj -o $@ unix.cmxa str.cmxa $^ +else +$(OBJDIR)/libcil.a: + @echo "Can only build $@ when NATIVECAML is 1." + exit 2 +endif + +# Test cil +ifdef _MSVC +TESTCILARG=--MSVC --testcil "bash msvctestcil" +else +TESTCILARG= --testcil "bash gcctestcil" +endif + +.PHONY: testcil +testcil: $(OBJDIR)/cilly$(EXE) + cd test; ../$(OBJDIR)/cilly$(EXE) $(TESTCILARG) + +.PHONY: odoc texdoc pdfdoc + +### +### DOCUMENTATION +### +### The following are available +### +### make doc - creates the documentation +### make publish_doc - creates the documentation and puts it on the web page + +# Documentation generated by "ocamldoc" +odoc: $(OBJDIR)/pretty.cmi $(OBJDIR)/cil.cmi + -rm -rf doc/html/cil/api + -mkdir doc/html/cil/api + -mkdir doc/html/cil/api-latex + -rm -f doc/ocamldoc.sty + ocamldoc -d doc/html/cil/api -v -stars \ + -html \ + -t "CIL API Documentation (version @CIL_VERSION@)" \ + -I $(OBJDIR) \ + ocamlutil/pretty.mli ocamlutil/errormsg.mli \ + ocamlutil/clist.mli \ + ocamlutil/stats.mli src/cil.mli src/formatcil.mli \ + ocamlutil/alpha.mli src/cillower.mli \ + src/ext/cfg.mli src/ext/dataflow.mli \ + src/ext/dominators.mli + +doc/cilpp.tex: doc/cilcode.pl doc/cil.tex + -rm -rf doc/html/cil + -mkdir doc/html/cil + -mkdir doc/html/cil/examples + cd doc; perl cilcode.pl cil.tex >cilpp.tex.tmp + mv doc/cilpp.tex.tmp $@ + +# Documentation generated from latex files using "hevea" +texdoc: doc/cilpp.tex +# Create the version document + cd doc/html/cil; echo "\def\cilversion{@CIL_VERSION@}" >cil.version.tex + cd doc/html/cil; echo "\def\ccuredversion{@CCURED_VERSION@}" >>cil.version.tex + cd doc/html/cil; hevea -exec xxdate.exe ../../cilpp + cd doc/html/cil; hevea -exec xxdate.exe ../../cilpp + cd doc/html/cil; mv cilpp.html cil.html + cd doc/html/cil; hacha -o ciltoc.html cil.html + cp -f doc/index.html doc/html/cil/index.html + cp -f doc/header.html doc/html/cil + +pdfdoc: doc/cilpp.tex $(OBJDIR)/pretty.cmi $(OBJDIR)/cil.cmi + cd doc; echo "\def\cilversion{@CIL_VERSION@}" >cil.version.tex + cd doc; echo "\def\ccuredversion{@CCURED_VERSION@}" >>cil.version.tex + cd doc; pdflatex cilpp.tex; pdflatex cilpp.tex + cd doc; mv cilpp.pdf html/cil/CIL.pdf + ocamldoc -o doc/cil-api.tex -v -stars \ + -latex \ + -t "CIL API Documentation (version @CIL_VERSION@)" \ + -I $(OBJDIR) \ + ocamlutil/pretty.mli ocamlutil/errormsg.mli \ + ocamlutil/clist.mli \ + ocamlutil/stats.mli src/cil.mli src/formatcil.mli \ + ocamlutil/alpha.mli + + cd doc ; TEXINPUTS="$$TEXINPUTS:/usr/local/lib/ocaml/ocamldoc:/usr/lib/ocaml/ocamldoc" pdflatex cil-api.tex + cd doc ; mv cil-api.pdf html/cil/CIL-API.pdf + +doc: texdoc pdfdoc odoc + + +#---------------------------------------------------------------------- +# Generate the CIL distribution +# This will create a file cil.tar.gz. It includes the HTML documentation +# so that people can use it even if they don't have ocamldoc, hevea etc. + +.PHONY: distrib distrib-nocheck checkdistrib +CIL_TAR_GZ:=cil-@CIL_VERSION@.tar.gz +## Make a distribution and check it +distrib: distrib-nocheck checkdistrib + +# Work in a temporary directory +TEMP_DIR = TEMP_cil-distrib + +# The tar archive members will be relative to this directory +TOP_DIR = $(TEMP_DIR)/cil + +DISTRIB_ROOT = README LICENSE INSTALL Makefile.in \ + config.h.in Makefile.gcc Makefile.msvc \ + configure configure.in install-sh config.guess config.sub \ + cil.spec cil.spec.in + +DISTRIB_SRC = cilutil.ml cil.ml cil.mli check.ml check.mli \ + rmtmps.ml rmtmps.mli formatlex.mll formatparse.mly \ + formatcil.mli formatcil.ml testcil.ml \ + mergecil.ml mergecil.mli main.ml machdep.c \ + ciloptions.ml ciloptions.mli libmaincil.ml \ + escape.ml escape.mli cillower.mli cillower.ml + +DISTRIB_OCAMLUTIL = pretty.ml pretty.mli errormsg.ml errormsg.mli \ + trace.ml trace.mli stats.ml stats.mli util.ml util.mli \ + inthash.ml inthash.mli alpha.ml alpha.mli \ + intmap.ml intmap.mli clist.ml clist.mli \ + growArray.ml growArray.mli \ + perfcount.c.in Makefile.ocaml Makefile.ocaml.build + + +DISTRIB_SRC_FRONTC = cabs.ml cprint.ml clexer.mli clexer.mll \ + cparser.mly lexerhack.ml \ + cabs2cil.ml cabs2cil.mli frontc.ml frontc.mli \ + cabsvisit.mli cabsvisit.ml patch.mli patch.ml + +DISTRIB_SRC_EXT = logcalls.ml logcalls.mli \ + astslicer.ml heap.ml partial.ml \ + logwrites.ml heapify.ml callgraph.ml callgraph.mli \ + epicenter.ml usedef.ml ciltools.ml \ + cfg.ml deadcodeelim.ml availexps.ml \ + dataflow.ml dataflow.mli \ + dominators.ml dominators.mli \ + bitmap.ml bitmap.mli \ + ssa.ml ssa.mli \ + stackoverflow.mli stackoverflow.ml \ + canonicalize.ml canonicalize.mli \ + oneret.ml oneret.mli sfi.ml \ + simplemem.ml simplify.ml \ + blockinggraph.ml blockinggraph.mli \ + dataslicing.ml dataslicing.mli \ + reachingdefs.ml \ + cfg.ml cfg.mli \ + liveness.ml + +DISTRIB_SRC_EXT_PTA = setp.ml setp.mli golf.ml golf.mli \ + ptranal.ml ptranal.mli \ + steensgaard.mli steensgaard.ml \ + uref.ml uref.mli olf.ml olf.mli + +DISTRIB_LIB = Cilly.pm KeptFile.pm OutputFile.pm TempFile.pm + +DISTRIB_BIN = CilConfig.pm.in cilly cilly.bat.in \ + patcher patcher.bat.in test-bad teetwo + +DISTRIB_SMALL1=hello.c func.c init.c init1.c wchar1.c vararg1.c testharness.h + +distrib-nocheck: $(DISTRIB_ROOT) doc + # Create the distribution from scratch + rm -rf $(TEMP_DIR) + mkdir $(TEMP_DIR) + + rm -rf $(CIL_TAR_GZ) + mkdir $(TOP_DIR) \ + $(TOP_DIR)/src \ + $(TOP_DIR)/src/frontc \ + $(TOP_DIR)/src/ext \ + $(TOP_DIR)/src/ext/pta \ + $(TOP_DIR)/obj \ + $(TOP_DIR)/doc \ + $(TOP_DIR)/lib \ + $(TOP_DIR)/bin \ + $(TOP_DIR)/doc/api \ + $(TOP_DIR)/obj/.depend \ + $(TOP_DIR)/obj/x86_WIN32 \ + $(TOP_DIR)/obj/x86_LINUX \ + $(TOP_DIR)/obj/ppc_DARWIN \ + $(TOP_DIR)/obj/sparc_SOLARIS \ + $(TOP_DIR)/test \ + $(TOP_DIR)/test/small1 \ + $(TOP_DIR)/ocamlutil + + cp $(patsubst %,%,$(DISTRIB_ROOT)) $(TOP_DIR) + + cp $(patsubst %,src/%,$(DISTRIB_SRC)) $(TOP_DIR)/src + cp $(patsubst %,ocamlutil/%,$(DISTRIB_OCAMLUTIL)) $(TOP_DIR)/ocamlutil + cp $(patsubst %,src/ext/%,$(DISTRIB_SRC_EXT)) $(TOP_DIR)/src/ext + cp $(patsubst %,src/ext/pta/%,$(DISTRIB_SRC_EXT_PTA)) \ + $(TOP_DIR)/src/ext/pta + cp $(patsubst %,src/frontc/%,$(DISTRIB_SRC_FRONTC)) \ + $(TOP_DIR)/src/frontc + cp $(patsubst %,lib/%,$(DISTRIB_LIB)) $(TOP_DIR)/lib + cp $(patsubst %,bin/%,$(DISTRIB_BIN)) $(TOP_DIR)/bin + cp $(patsubst %,test/small1/%,$(DISTRIB_SMALL1)) $(TOP_DIR)/test/small1 + + cp -r doc/html/cil/* $(TOP_DIR)/doc +# Delete all CVS directories + if find $(TEMP_DIR) -name CVS -print >cvss.txt ; then \ + rm -rf `cat cvss.txt` ;fi +# Now make the TAR ball + cd $(TEMP_DIR); tar cfz $(CIL_TAR_GZ) cil + mv $(TEMP_DIR)/$(CIL_TAR_GZ) . + +# rm -rf $(TEMP_DIR) + +## Check a distribution +checkdistrib: + cd $(TOP_DIR) && ./configure && \ + $(MAKE) && $(MAKE) quicktest + +distclean: clean + rm -f src/frontc/cparser.output + rm -f src/formatparse.output + rm -f ocamlutil/perfcount.c + rm -f bin/cilly.bat + rm -f bin/patcher.bat + rm -f bin/CilConfig.pm + rm -f config.log + rm -f config.h + rm -f Makefile + +## Publish the distribution +CILHTMLDEST=/var/www/cil +publish_distrib: publish_doc + if test -d $(CILHTMLDEST); then \ + cp -rf doc/html/cil/* $(CILHTMLDEST); \ + cp -f $(CIL_TAR_GZ) $(CILHTMLDEST)/distrib; \ + ln -sf $(CILHTMLDEST)/distrib/$(CIL_TAR_GZ) $(CILHTMLDEST)/distrib/cil-latest.tar.gz ; \ + echo "Publish succeeded"; \ + else \ + error "Cannot publish because $(CILHTMLDEST) does not exist" ; \ + fi + +publish_doc: doc + if test -d $(CILHTMLDEST); then \ + cp -rf doc/html/cil/* $(CILHTMLDEST); echo "Done publishing doc"; \ + else \ + error "Cannot publish because $(CILHTMLDEST) does not exist" ; \ + fi + +cleancheck: + rm -f test/small1/*.o + rm -f test/small1/hello + rm -f test/small1/vararg1 + rm -f test/small1/wchar1 + +clean: cleancaml cleancheck + rm -f $(OBJDIR)/machdep.ml + +# Now include the compiler specific stuff +ifdef _MSVC + include Makefile.msvc +else + ifdef _GNUCC + include Makefile.gcc + endif +endif + +test/%: + bin/cilly $(CONLY) test/small1/$*.c $(OBJOUT)test/small1/$*.o + +testrun/%: + bin/cilly test/small1/$*.c $(OBJOUT)test/small1/$* + test/small1/$* + + + +.PHONY: quicktest +quicktest: $(patsubst %,test/%,func init init1) \ + $(patsubst %,testrun/%,hello wchar1 vararg1) + +.PHONY: check +check: quicktest + +############# Binary distribution ################ +.PHONY: bindistrb checkbindistrib + +BINCIL_TAR_GZ:=cil-win32-@CIL_VERSION@.tar.gz + +# Work in a temporary directory +BINTEMP_DIR = TEMP_cil-bindistrib + +# The tar archive members will be relative to this directory +BINTOP_DIR = $(BINTEMP_DIR)/cil + +BINDISTRIB_ROOT = README LICENSE + +BINDISTRIB_LIB = Cilly.pm KeptFile.pm OutputFile.pm TempFile.pm + +BINDISTRIB_BIN = CilConfig.pm.in cilly cilly.bat.in \ + patcher patcher.bat.in + +BINDISTRIB_OBJ = cilly.byte.exe cilly.asm.exe + +BINDISTRIB_SMALL1=hello.c + +bindistrib-nocheck: $(BINDISTRIB_ROOT) obj/x86_WIN32/cilly.asm.exe + # Create the distribution from scratch + rm -rf $(BINTEMP_DIR) + mkdir $(BINTEMP_DIR) + + mkdir $(BINTOP_DIR) \ + $(BINTOP_DIR)/obj \ + $(BINTOP_DIR)/doc \ + $(BINTOP_DIR)/lib \ + $(BINTOP_DIR)/bin \ + $(BINTOP_DIR)/doc/api \ + $(BINTOP_DIR)/obj/.depend \ + $(BINTOP_DIR)/obj/x86_WIN32 \ + $(BINTOP_DIR)/test \ + $(BINTOP_DIR)/test/small1 + + cp $(patsubst %,%,$(BINDISTRIB_ROOT)) $(BINTOP_DIR) + cp $(patsubst %,lib/%,$(BINDISTRIB_LIB)) $(BINTOP_DIR)/lib + cat bin/CilConfig.pm.in \ + | sed -e "s|@||g" \ + | sed -e "s|CC|cl|" \ + | sed -e "s|DEFAULT_CIL_MODE|MSVC|" \ + | sed -e "s|ARCHOS|x86_WIN32|" \ + > $(BINTOP_DIR)/bin/CilConfig.pm + cat bin/patcher.bat.in | sed -e "s|@||g" >$(BINTOP_DIR)/bin/patcher.bat + cp bin/patcher $(BINTOP_DIR)/bin + cp bin/cilly $(BINTOP_DIR)/bin + cat bin/cilly.bat.in | sed -e "s|@||g" > $(BINTOP_DIR)/bin/cilly.bat + cp $(patsubst %,test/small1/%,$(BINDISTRIB_SMALL1)) \ + $(BINTOP_DIR)/test/small1 + cp $(patsubst %,obj/x86_WIN32/%,$(BINDISTRIB_OBJ)) \ + $(BINTOP_DIR)/obj/x86_WIN32 + + cp -r doc/html/cil/* $(BINTOP_DIR)/doc +# Delete all CVS directories + if find $(BINTEMP_DIR) -name CVS -print >cvss.txt ; then \ + rm -rf `cat cvss.txt` ;fi +# Now make the TAR ball + cd $(BINTEMP_DIR); tar cfz $(BINCIL_TAR_GZ) cil + mv $(BINTEMP_DIR)/$(BINCIL_TAR_GZ) . + +# rm -rf $(TEMP_DIR) + +## Check a distribution +checkbindistrib: + +######################################################################## + + +INSTALL = @INSTALL@ +INSTALL_DATA = @INSTALL_DATA@ + +prefix = @prefix@ +exec_prefix = @exec_prefix@ +libdir = @libdir@ +pkglibdir = $(libdir)/cil +datadir = @datadir@ +pkgdatadir = $(datadir)/cil + +all_mli := $(filter %.mli, $(DISTRIB_OCAMLUTIL) $(DISTRIB_SRC) $(DISTRIB_SRC_FRONTC) $(DISTRIB_SRC_EXT) $(DISTRIB_SRC_EXT_PTA)) +install_mli := $(filter $(OCAML_CIL_LIB_MODULES:=.mli), $(all_mli)) +install_cmi := $(install_mli:%.mli=$(OBJDIR)/%.cmi) +install_cma := $(addprefix $(OBJDIR)/cil., cma cmxa a) +install_lib := $(OCAML_CIL_LIB_CMODULES:%=$(OBJDIR)/lib%.a) + +install: $(install_cmi) $(install_cma) $(install_lib) + $(INSTALL) -d $(DESTDIR)$(pkglibdir) + $(INSTALL_DATA) $(install_cma) $(DESTDIR)$(pkglibdir) + $(INSTALL_DATA) $(install_cmi) $(DESTDIR)$(pkglibdir) + $(INSTALL_DATA) $(install_lib) $(DESTDIR)$(pkglibdir) + $(INSTALL) -d $(DESTDIR)$(pkgdatadir) + $(INSTALL_DATA) $(addprefix lib/, $(filter %.pm, $(DISTRIB_LIB))) $(DESTDIR)$(pkgdatadir) + +cil.spec: cil.spec.in + ./config.status $@ + +rpms: distrib + rpmbuild -ta $(CIL_TAR_GZ) + diff --git a/cil/Makefile.msvc b/cil/Makefile.msvc new file mode 100644 index 0000000..be1bb38 --- /dev/null +++ b/cil/Makefile.msvc @@ -0,0 +1,42 @@ +# +# Makefile for CCured. The Microsoft Visual C part +# +COMPILERNAME=MSVC + +CC:=cl /nologo +ifdef RELEASELIB +#matth: we need the frame pointer for CHECK_GETFRAME, so +# use /Oy- to prevent that optimization. + CFLAGS:=/DRELEASE /D_MSVC /Ox /Ob2 /G6 /Oy- +else + CFLAGS:=/D_DEBUG /D_MSVC /Zi /MLd +endif +CONLY:=/c + +OPT_O2:= /Ox /Ob2 /G6 + +OBJOUT:=/Fo +OBJEXT:=obj + +EXEOUT:=/Fe +LIBEXT:=lib +LDEXT:=.exe + +DEF:=/D +ASMONLY:=/Fa +INC:=/I + +CPPSTART:=cl /Dx86_WIN32 /D_MSVC /E /TC /I./lib /DCCURED +CPPOUT:= >%o +CPP:=$(CPPSTART) /FI fixup.h %i $(CPPOUT) + +PATCHECHO:=echo + +AR:=lib +LIBOUT:=/OUT: + +# The system include files to be patched +PATCH_SYSINCLUDES:=stdio.h ctype.h string.h io.h stdarg.h crtdbg.h \ + varargs.h stdlib.h time.h malloc.h + + diff --git a/cil/README b/cil/README new file mode 100644 index 0000000..52710f2 --- /dev/null +++ b/cil/README @@ -0,0 +1,2 @@ + + See the documentation in doc/html. diff --git a/cil/bin/CilConfig.pm.in b/cil/bin/CilConfig.pm.in new file mode 100644 index 0000000..94241b1 --- /dev/null +++ b/cil/bin/CilConfig.pm.in @@ -0,0 +1,6 @@ + +$::archos = "@ARCHOS@"; +$::cc = "@CC@"; +$::cilhome = "@CILHOME@"; +$::default_mode = "@DEFAULT_CIL_MODE@"; + diff --git a/cil/bin/cilly b/cil/bin/cilly new file mode 100755 index 0000000..e4bf737 --- /dev/null +++ b/cil/bin/cilly @@ -0,0 +1,152 @@ +#!/usr/bin/perl +# A simple use of the Cilly module +# +# +# +# Copyright (c) 2001-2002, +# George C. Necula +# Scott McPeak +# Wes Weimer +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: +# +# 1. Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# +# 3. The names of the contributors may not be used to endorse or promote +# products derived from this software without specific prior written +# permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +use strict; +use Data::Dumper; +use FindBin; +use lib "$FindBin::Bin"; +use lib "$FindBin::Bin/../lib"; # The libraries are in the lib directory +# Read the configuration script +use CilConfig; + +use Cilly; + +$::default_is_merge = 0; +my $stub = CilCompiler->new(@ARGV); + +$stub->setVersion (); + +# print Dumper($stub); +$stub->doit(); + + +# Define here your favorite compiler by overriding Merger methods +package CilCompiler; +use File::Basename; +use strict; +BEGIN { + @CilCompiler::ISA = qw(Cilly); + $CilCompiler::base = "$::cilhome/obj/$::archos/cilly"; + # Use the most recent version of cilly + $CilCompiler::mtime_asm = int((stat("$CilCompiler::base.asm.exe"))[9]); + $CilCompiler::mtime_byte = int((stat("$CilCompiler::base.byte.exe"))[9]); + $CilCompiler::use_debug = + grep(/--bytecode/, @ARGV) || + grep(/--ocamldebug/, @ARGV) || + ($CilCompiler::mtime_asm < $CilCompiler::mtime_byte); + $CilCompiler::compiler = + $CilCompiler::base . + ($CilCompiler::use_debug ? ".byte" : ".asm") . ".exe"; + if($CilCompiler::use_debug) { + $ENV{"OCAMLRUNPARAM"} = "b" . $ENV{"OCAMLRUNPARAM"}; + } +} + +# We need to customize the collection of arguments +sub collectOneArgument { + my($self, $arg, $pargs) = @_; + if($arg =~ m|--transval=(.+)$|) { + $self->{TRANSVAL} = $1; return 1; + } + if($arg eq '--ocamldebug') { + $self->{OCAMLDEBUG} = 1; return 1; + } + if($arg eq '--cabsonly') { + $self->{CABSONLY} = 1; return 1; + } + # See if the super class understands this + return $self->SUPER::collectOneArgument($arg, $pargs); +} + +sub usage { + print "Usage: cilly [options] [gcc_or_mscl arguments]\n"; +} + +sub helpMessage { + my($self) = @_; + # Print first the original + $self->SUPER::helpMessage(); + print <runShell(@cmd); +} + + +sub CillyCommand { + my ($self, $ppsrc, $dest) = @_; + + my $aftercil; + my @cmd = ($CilCompiler::compiler); + + if(defined $ENV{OCAMLDEBUG} || $self->{OCAMLDEBUG}) { + print "OCAMLDEBUG is on\n"; + my @idirs = ("src", "src/frontc", "src/ccured", "src/ext", + "ocamlutil", + "obj/$::archos"); + my @iflags = map { ('-I', "$::cilhome/$_") } @idirs; + unshift @cmd, 'ocamldebug', '-emacs', @iflags; + } + if($::docxx) { + push @cmd, '--cxx'; + } + if($self->{CABSONLY}) { + $aftercil = $self->cilOutputFile($dest, 'cabs.c'); + push @cmd, '--cabsonly', $aftercil; + } else { + if(defined $self->{CILLY_OUT}) { + $aftercil = new OutputFile($dest, $self->{CILLY_OUT}); + return ($aftercil, @cmd); + } + $aftercil = $self->cilOutputFile($dest, 'cil.c'); + } + return ($aftercil, @cmd, '--out', $aftercil); +} + +sub MergeCommand { + my ($self, $ppsrc, $dir, $base) = @_; + + return ('', $CilCompiler::compiler); +} + + +1; diff --git a/cil/bin/cilly.bat.in b/cil/bin/cilly.bat.in new file mode 100755 index 0000000..9e5a36e --- /dev/null +++ b/cil/bin/cilly.bat.in @@ -0,0 +1 @@ +perl @CILHOME@/bin/cilly %* diff --git a/cil/bin/patcher b/cil/bin/patcher new file mode 100755 index 0000000..6eb7d15 --- /dev/null +++ b/cil/bin/patcher @@ -0,0 +1,605 @@ +#!/usr/bin/perl +# A Perl script that patches a bunch of files +# +# +# +# Copyright (c) 2001-2002, +# George C. Necula +# Scott McPeak +# Wes Weimer +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: +# +# 1. Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# +# 3. The names of the contributors may not be used to endorse or promote +# products derived from this software without specific prior written +# permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# +use strict; +use File::Basename; +use File::Copy; +use Getopt::Long; # Command-line option processing +use Data::Dumper; +use FindBin; +use lib "$FindBin::Bin"; +use lib "$FindBin::Bin/../lib"; +# Read the configuration script +use CilConfig; + +$::iswin32 = $^O eq 'MSWin32' || $^O eq 'cygwin'; +# matth: On cygwin, ^O is either MSWin32 or cygwin, depending on how you build +# perl. We don't care about the distinction, so just treat all windows +# platforms the same when looking at "system=cygwin" tags on patches. +$::platform = $::iswin32 ? 'cygwin' : $^O; + + +# Set filename parsing according to current operating system. +File::Basename::fileparse_set_fstype($^O); + +sub printHelp { + print <) + + --clean Remove all files in the destination directory + --dumpversion Print the version name used for the current compiler + + All of the other arguments are passed to the preprocessor. + +We will use \"$::platform\" as your system type. + +Send bugs to necula\@cs.berkeley.edu. +EOL +} + + +my %option; +&Getopt::Long::Configure("pass_through"); +&Getopt::Long::GetOptions + (\%option, + "--help", # Display help information + "--verbose|v", # Display information about programs invoked + "--mode=s", # The mode (GNUCC, MSVC) + "--dest=s", # The destination directory + "--patch=s@", # Patch files + "--ufile=s@", # User include files + "--sfile=s@", # System include files + "--dumpversion", + "--clean", + ); + +if($option{help}) { + &printHelp(); + exit 0; +} + +# print Dumper({"option" => \%option, "ARGV" => \@ARGV}); + +my $cversion; # Compiler version +my $cname; # Compiler name +my @patches; # A list of the patches to apply + +my $ppargs = join(' ', @ARGV); + +my %groups; + +&findCompilerVersion(); + +if($option{dumpversion}) { + print $cversion; + exit 0; +} + +# Find the destination directory +if(!defined($option{dest})) { + die "Must give a --dest directory\n"; +} +if(! -d $option{dest}) { + die "The destination directory $option{dest} does not exist\n"; +} + +if($option{clean}) { + # Find the destination directory for a dummy file + my $dest = &destinationFileName(""); + chop $dest; # The final / + print "Cleaning all files in $dest\n"; + (!system("rm -rf $dest")) || die "Cannot remove directory\n"; + exit 0; +} + +print "Patching files for $cname version $cversion\n"; + +# Prepare the patches +if(defined($option{patch})) { + my $pFile; + foreach $pFile (@{$option{patch}}) { + &preparePatchFile($pFile); + } +} + +# print Dumper(\@patches); + +my $file; +foreach $file (@{$option{ufile}}) { + &patchOneFile($file, 0); +} +foreach $file (@{$option{sfile}}) { + &patchOneFile($file, 1); +} + +# Now check whether we have used all the patches +my $hadError = 0; +foreach my $patch (@patches) { + # It was optional + if(defined $patch->{FLAGS}->{optional} || + defined $patch->{FLAGS}->{disabled}) { next; } + # It was for another system + if(defined $patch->{FLAGS}->{system} && + $patch->{FLAGS}->{system} ne $::platform) { next; } + # Its group was done + if(defined $patch->{FLAGS}->{group}) { + if(! defined $groups{$patch->{FLAGS}->{group}}) { + $hadError = 1; + print "None of the following patches from group $patch->{FLAGS}->{group} was used:\n"; + foreach my $gp (@patches) { + if($gp->{FLAGS}->{group} eq $patch->{FLAGS}->{group}) { + print "\tfrom $gp->{PATCHFILE} at $gp->{PATCHLINENO}\n"; + } + } + $groups{$patch->{FLAGS}->{group}} = 1; # We're done with it + } + next; + } + # It was not in a group and was not optional + if(! defined $patch->{USED}) { + $hadError = 1; + print "Non-optional patch was not used:\n\tfrom $patch->{PATCHFILE} at $patch->{PATCHLINENO}\n"; + next; + } +} +exit $hadError; + + +############# SUBROUTINES +sub findCompilerVersion { + $cname = ""; + $cversion = 0; + if($option{mode} eq "GNUCC") { + $cname = "GNU CC"; + open(VER, "$::cc -dumpversion $ppargs|") + || die "Cannot start $cname"; + while() { + # sm: had to modify this to match "egcs-2.91.66", which is + # how egcs responds to the -dumpversion request + if($_ =~ m|^(\d+\S+)| || + $_ =~ m|^(egcs-\d+\S+)|) { + $cversion = "gcc_$1"; + close(VER) || die "Cannot start $cname\n"; + return; + } + } + die "Cannot find the version for GCC\n"; + } + if($option{mode} eq "MSVC") { + $cname = "Microsoft cl"; + $ppargs =~ s|/nologo||g; + open(VER, "cl $ppargs 2>&1|") || die "Cannot start $cname: cl $ppargs\n"; + while() { + if($_ =~ m|Compiler Version (\S+) |) { + $cversion = "cl_$1"; + close(VER); + return; + } + } + die "Cannot find the version for Microsoft CL\n"; + } + die "You must specify a --mode (either GNUCC or MSVC)"; +} + +sub lineDirective { + my ($fileName, $lineno) = @_; + if($::iswin32) { + $fileName =~ s|\\|/|g; + } + if($option{mode} eq "MSVC") { + return "#line $lineno \"$fileName\"\n"; + } + if($option{mode} eq "GNUCC" || $option{mode} eq "EDG") { + return "# $lineno \"$fileName\"\n"; + } + die "lineDirective: invalid mode"; +} + +# Find the absolute name for a file +sub patchOneFile { + my ($fname, $issys) = @_; + my $fname1 = $issys ? "<$fname>" : "\"$fname\""; + print "Patching $fname1\n"; + my $preprocfile = "__topreproc"; + unlink "$preprocfile.i"; + open(TOPREPROC, ">$preprocfile.c") || die "Cannot open preprocessor file"; + print TOPREPROC "#include $fname1\n"; + close(TOPREPROC); + # Do not test for error while running the preprocessor because the + # error might be due to an #error directive + my $preproccmd = ""; + if($option{mode} eq "GNUCC") { + $preproccmd = "$::cc -E $ppargs $preprocfile.c >$preprocfile.i"; + if ($^O ne 'MSWin32') { # Windows has no /dev/null + # ignore stderr (e.g. #error directives) + $preproccmd .= " 2>/dev/null"; + } + } elsif($option{mode} eq "MSVC") { + $preproccmd = "cl /nologo /P $ppargs $preprocfile.c"; + } else { die "Invalid --mode"; } + + if(system($preproccmd) && $option{mode} eq "MSVC" ) { + # For some reason the gcc returns spurious error codes + die "Error running preprocessor: $preproccmd" + } + + # Now scan the resulting file and get the real name of the file + my $absname = ""; + open(PPOUT, "<$preprocfile.i") || die "Cannot find $preprocfile.i"; + while() { + if($_ =~ m|^\#.+\"(.+$fname)\"|) { + $absname = $1; + last; + } + } + close(PPOUT); + if($absname eq "") { + die "Cannot find the absolute name of $fname1 in $preprocfile.i\n"; + } + unlink "$preprocfile.c"; + unlink "$preprocfile.i"; + # If we fail then maybe we are using cygwin paths in a Win32 system + if($option{mode} eq "GNUCC" && $::iswin32) { + open(WINNAME, "cygpath -w $absname|") + || die "Cannot run cygpath to convert $absname to a Windows name"; + $absname = ; + if($absname =~ m|\n$|) { + chop $absname; + } + # print "Converted $fileName to $newName\n"; + close(WINNAME) || die "Cannot run cygpath to convert $absname"; + } + if(! -f $absname) { #matth: we need to do this test after calling cygpath + die "Cannot find the absolute name of $fname1 (\"$absname\")\n"; + } + print " Absolute name is $absname\n"; + # Decide where to put the result + my $dest = &destinationFileName($fname); + print " Destination is $dest\n"; + &applyPatches($absname, $dest); +} + +# Is absolute path name? +sub isAbsolute { + my($name) = @_; + if($::iswin32) { + return ($name =~ m%^([a-zA-Z]:)?[/\\]%); + } else { + return ($name =~ m%^[/\\]%); + } +} + +# Compute the destination file name and create all necessary directories +sub destinationFileName { + my ($fname) = @_; + if(&isAbsolute($fname)) { + die "Cannot process files that have absolute names\n"; + } + my $dest = $option{dest} . "/" . $cversion; + # Break the file name into components + my @fnamecomp = split(m%[/\\]%, $fname); + # Add one component at a time + do { + if(! -d $dest) { + (mkdir $dest, 0777) || die "Cannot create directory $dest\n"; + } + my $comp = shift @fnamecomp; + $dest .= ('/' . $comp); + } while($#fnamecomp >= 0); + return $dest; +} +##################################################################### +# Patching of files +# +sub preparePatchFile { + my ($pFile) = @_; + open(PFILE, "<$pFile") || + die "Cannot read patch file $pFile\n"; + my $patchLineNo = 0; + my $patchStartLine = 0; + NextPattern: + while() { + $patchLineNo ++; + if($_ !~ m|^<<<(.*)$|) { + next; + } + # Process the flags + my @patchflags = split(/\s*,\s*/, $1); + my %valueflags; + foreach my $flg (@patchflags) { + $flg = &trimSpaces($flg); + if($flg =~ m|^(.+)\s*=\s*(.+)$|) { + $valueflags{$1} = $2; + } else { + $valueflags{$flg} = 1; + } + } + # Now we have found the start + $_ = ; + $patchLineNo ++; + my $current_pattern = []; + my @all_patterns = (); + if($_ =~ m|^===|) { + if(! defined $valueflags{ateof} && + ! defined $valueflags{atsof}) { + die "A pattern is missing in $pFile"; + } + goto AfterPattern; + } + if($_ eq "") { + die "A pattern is missing in $pFile"; + } + push @{$current_pattern}, $_; + + while() { + $patchLineNo ++; + if($_ =~ m|^===|) { + last; + } + if($_ =~ m%^\|\|\|%) { + # This is an alternate pattern + push @all_patterns, $current_pattern; + $current_pattern = []; + next; + } + push @{$current_pattern}, $_; + } + AfterPattern: + # Finish off the last pattern + push @all_patterns, $current_pattern; + if($_ !~ m|^===|) { + die "No separator found after pattern in $pFile"; + } + $patchStartLine = $patchLineNo + 1; + my $replacement = ""; + # If we have more than one non-optional pattern with no group + # specified, then create a group + if(@all_patterns > 1 && + ! defined $valueflags{group} && + ! defined $valueflags{optional}) { + $valueflags{group} = $pFile . "_$patchStartLine"; + } + while() { + $patchLineNo ++; + if($_ =~ m|^>>>|) { + # For each alternate pattern + my $patt; + foreach $patt (@all_patterns) { + # Maybe the @__pattern__@ string appears in the replacement + my $pattern_repl = join('', @{$patt}); + my $nrlines = int(@{$patt}); + my $local_repl = $replacement; + $local_repl =~ s/\@__pattern__\@/$pattern_repl/g; + # Strip the spaces from patterns + my @pattern_no_space = (); + my $i; + foreach $i (@{$patt}) { + $i =~ s/\s+//g; + push @pattern_no_space, $i; + } + push @patches, { HEAD => $pattern_no_space[0], + FLAGS => \%valueflags, + NRLINES => $nrlines, + PATTERNS => \@pattern_no_space, + REPLACE => $local_repl, + PATCHFILE => $pFile, + PATCHLINENO => $patchStartLine, + }; + } + next NextPattern; + } + $replacement .= $_; + } + die "Unfinished replacement for pattern in $pFile"; + } + close(PFILE) || + die "Cannot close patch file $pFile\n"; + print "Loaded patches from $pFile\n"; + # print Dumper(\@patches); die "Here\n"; + +} + +sub trimSpaces { + my($str) = @_; + if($str =~ m|^\s+(\S.*)$|) { + $str = $1; + } + if($str =~ m|^(.*\S)\s+$|) { + $str = $1; + } + return $str; +} + + +my @includeReadAhead = (); +sub readIncludeLine { + my($infile) = @_; + if($#includeReadAhead < 0) { + my $newLine = <$infile>; + return $newLine; + } else { + return shift @includeReadAhead; + } +} + +sub undoReadIncludeLine { + my($line) = @_; + push @includeReadAhead, $line; +} + +sub applyPatches { + my($in, $out) = @_; + # Initialize all the patches + my $patch; + # And remember the EOF patches that are applicable here + my @eof_patches = (); + foreach $patch (@patches) { + $patch->{USE} = 1; + my $infile = $patch->{FLAGS}->{file}; + if(defined $infile && $in !~ m|$infile$|) { +# print "Will not use patch ", +# &lineDirective($patch->{PATCHFILE},$patch->{PATCHLINENO}); + $patch->{USE} = 0; + next; + } + # Disable the system specific patterns + if(defined $patch->{FLAGS}->{system} && + $patch->{FLAGS}->{system} ne $::platform) { + $patch->{USE} = 0; + next; + } + # Disable also (for now) the patches that must be applied at EOF + if(defined $patch->{FLAGS}->{ateof} || + defined $patch->{FLAGS}->{atsof} || + defined $patch->{FLAGS}->{disabled} ) { + $patch->{USE} = 0; + push @eof_patches, $patch; + } + + } + + open(OUT, ">$out") || die "Cannot open patch output file $out"; + open(IN, "<$in") || die "Cannot open patch input file $in"; + + @includeReadAhead = (); + + my $lineno = 0; + my $line; # The current line + + # the file name that should be printed in the line directives + my $lineDirectiveFile = $in; + # Now apply the SOF patches + foreach my $patch (@eof_patches) { + if(defined $patch->{FLAGS}->{atsof}) { + my $line = &applyOnePatch($patch, &lineDirective($in, $lineno)); + print OUT $line; + } + } + + while($line = &readIncludeLine(\*IN)) { + $lineno ++; + # Now we have a line to print out. See if it needs patching + my $patch; + my @lines = ($line); # A number of lines + my $nrLines = 1; # How many lines + my $toundo = 0; + NextPatch: + foreach $patch (@patches) { + if(! $patch->{USE}) { next; } # We are not using this patch + my $line_no_spaces = $line; + $line_no_spaces =~ s/\s+//g; + if($line_no_spaces eq $patch->{HEAD}) { + # Now see if all the lines match + my $patNrLines = $patch->{NRLINES}; + if($patNrLines > 1) { + # Make sure we have enough lines + while($nrLines < $patNrLines) { + push @lines, &readIncludeLine(\*IN); + $nrLines ++; + $toundo ++; + } + my @checkLines = @{$patch->{PATTERNS}}; + my $i; + # print "check: ", join(":", @checkLines); + # print "with $nrLines lines: ", join("+", @lines); + for($i=0;$i<$patNrLines;$i++) { + $line_no_spaces = $lines[$i]; + $line_no_spaces =~ s/\s+//g; + if($checkLines[$i] ne $line_no_spaces) { + # print "No match for $patch->{HEAD}\n"; + next NextPatch; + } + } + } + # print "Using patch from $patch->{PATCHFILE}:$patch->{PATCHLINENO} at $in:$lineno\n"; + # Now replace + $lineno += ($patNrLines - 1); + $toundo -= ($patNrLines - 1); + $line = &applyOnePatch($patch, &lineDirective($in, $lineno + 1)); + last; + } + } + print OUT $line; + # Now undo all but the first line + my $i; + for($i=$nrLines - $toundo;$i<$nrLines;$i++) { + &undoReadIncludeLine($lines[$i]); + } + } + close(IN) || die "Cannot close file $in"; + # Now apply the EOF patches + foreach $patch (@eof_patches) { + if(defined $patch->{FLAGS}->{ateof}) { + my $line = &applyOnePatch($patch, &lineDirective($in, $lineno)); + print OUT $line; + } + } + + close(OUT); + return 1; +} + + +sub applyOnePatch { + my($patch, $after) = @_; + my $line = &lineDirective($patch->{PATCHFILE}, + $patch->{PATCHLINENO}); + $line .= $patch->{REPLACE}; + $line .= $after; + # Mark that we have used this group + $patch->{USED} = 1; + if(defined $patch->{FLAGS}->{group}) { + $groups{$patch->{FLAGS}->{group}} = 1; + } + return $line; +} diff --git a/cil/bin/patcher.bat.in b/cil/bin/patcher.bat.in new file mode 100755 index 0000000..2e356ae --- /dev/null +++ b/cil/bin/patcher.bat.in @@ -0,0 +1 @@ +perl @CILHOME@/bin/patcher %* diff --git a/cil/bin/teetwo b/cil/bin/teetwo new file mode 100755 index 0000000..2aa68fa --- /dev/null +++ b/cil/bin/teetwo @@ -0,0 +1,36 @@ +#!/bin/bash +# run a command, sending stdout to one file and stderr to another, +# but also sending both to this process' stdout/stderr, respectively + +if [ "$3" = "" ]; then + echo "usage: $0 stdout-file stderr-file cmd [args..]" + exit 0 +fi + +stdoutFile="$1" +stderrFile="$2" +command="$3" +shift +shift +shift + +result=0 +handler() { + # this signal means the underlying command exit erroneously, + # though we don't know the code + echo "The command failed!" + result=2 +} +trap handler SIGUSR1 + +# dup my stdout/err on fd 3,4 +exec 3>&1 +exec 4>&2 + + +# run the command with tees to duplicate the data +mypid=$$ +# echo "mypid = $mypid, command=$command, args=$@, stdout=$stdoutFile, stderr=$stderrFile" +(("$command" "$@" || kill -s USR1 $mypid) | tee "$stdoutFile" >&3) 2>&1 | tee "$stderrFile" >&4 + +exit $result diff --git a/cil/bin/test-bad b/cil/bin/test-bad new file mode 100755 index 0000000..4eacdc0 --- /dev/null +++ b/cil/bin/test-bad @@ -0,0 +1,202 @@ +#!/bin/sh +# run a regression test containing one or more intentional failures +# +# To create a source file to be processed by this script do the following: +# - the file should be a standalone program with main without any arguments +# You can add other files as part of the CFLAGS variable +# - add a comment +# // NUMERRORS n +# where n is the number of errors to be tested by this file +# +# This file is processed n+1 times. The first time, it should succeed (main returns or +# exits with code 0) and the other n times it should fail. +# For each run the preprocessor variable ERROR is defined to be +# be k (0 <= k <= n). +# You can mark certain lines in your program so that they are used ONLY in a certain run: put the +# following comment after a line to make it appear only in the run with ERROR == 3 +# +# some_code; // ERROR(3) +# +# +# Furthermore, for each run that is intended to fail you can specify a string that +# must appear in the output. +# +# some_code; // ERROR(3):this string must appear in output +# +# Do not put any spaces around the : +# +# Simple example: +# +# #define E(n) {printf("Error %d\n", n); exit(n); } +# #define SUCCESS {printf("Success\n"); exit(0); } +# +# // NUMERRORS 3 +# int main() { +# +# char char x; // ERROR(1):invalid type specifier +# int y; +# int z = ++y; +# // This conditional should be true +# if(z == y) E(2); // ERROR(2):Error 2 +# +# #if ERROR == 3 +# z = (++y, y--); +# if(z == y + 1) E(3); // ERROR(3):Error 3 +# #endif +# +# SUCCESS; +# } +# +# +# set RUNONLY=n to run only the test case n +# + +if [ "$1" = "" ]; then + # most parameters are passed by name, instead of as positional + # arguments, for better impedance match with Makefile; but it's + # good to have at least 1 positional arg so when it's missing I + # can easily tell, and print this message + echo "usage: CILHOME=... CILLY=... CFLAGS=... $0 source-file.c" + echo "You can also set RUNONLY=n to run only the nth iteration" + exit 0 +fi +echo "CILLY=$CILLY" +echo "CFLAGS=$CFLAGS" +srcfile="$1" +# Construct the name of the temporary file to use +srcfilenoext=`echo $srcfile | sed s/.c\$//` +tmpname="$srcfilenoext-tmp" + +# for GCC, use "# xx foo.c". For MSVC, use "#line xx foo.c" +if [ "$_MSVC" != "" ]; then + LINEOPT="line" + OUTFLAG="/Fe" + OUTEXT=".exe" +else + LINEOPT="" + OUTFLAG="-o " + OUTEXT=".exe" # So that I can delete the executables +fi + +# Start it in the right directory +# cd "$CILLYHOME/test/small2" || exit + +# read how many failure cases are in the file; expect line of form +# "// NUMERRORS n" +numcases=`grep NUMERRORS "$srcfile" | perl -e '$_ = <>; m|(\d+)|; print $1;'` +if [ -z "$numcases" ]; then + echo "didn't find a string of form NUMERRORS in the file" + exit 2 +fi +echo "there are $numcases failure cases in this file" + + +# iterate through the cases; first case (0) is where no errors are present +i=0 +if [ "$RUNONLY" != "" ] ;then + i=$RUNONLY +fi +while [ $i -le $numcases ]; do + echo + echo + echo "********************** Iteration $i" + echo + echo + # generate a temporary file; first hide the ERROR tags which identify + # the current test, then remove all remaining ERROR lines + # (syntax for errors has parentheses so if I have >=10 cases I don't + # run into problems where e.g. ERROR1 is a substring of ERROR10) + # use the little perl script to put line number directives where we remove + # lines + echo "generating test $i" + rm -f $tmpname.c 2>/dev/null + ( echo "#define ERROR $i"; echo "#$LINEOPT 1 \"$srcfile\"";cat "$srcfile") |\ + sed "s|ERROR($i)|(selected: $i)|" | \ + perl -e 'my $ln = 0; while(<>) { if($_ =~ m|ERROR\(|) { print "#'$LINEOPT' $ln\n"; } else { print $_; }; $ln ++}' \ + > "$tmpname.c" + chmod a-w "$tmpname.c" + + # Grab the errorline for this test case + themsg=`cat "$srcfile" | grep "ERROR($i).*:" | sed "s/^.*ERROR.*://" ` + if [ "x$themsg" != "x" ] ;then + echo "Expecting error message:$themsg" + fi + + # compile this with our tool + rm -f test-bad.out test-bad.err ${tmpname}$OUTEXT + echo $CILLY $CFLAGS $tmpname.c ${OUTFLAG}${tmpname}$OUTEXT + $CILHOME/bin/teetwo test-bad.out test-bad.err \ + $CILLY $CFLAGS -DERROR=$i $tmpname.c ${OUTFLAG}${tmpname}$OUTEXT + # cat test-bad.out test-bad.err + status=$? + runit=1 + if [ $status != 0 ]; then + if [ $i = 0 ] ;then + echo "The 0th iteration failed to CURE! It is supposed to succeed." + exit $status + else + if [ "x$themsg" != "x" ] ;then + echo "grep \"$themsg\" test-bad.out test-bad.err" + if ! grep "$themsg" test-bad.out test-bad.err ;then + echo "The ${i}th iteration failed to CURE but cannot find: $themsg" + exit 3 + else + echo "The ${i}th iteration failed to CURE, as expected!" + fi + else + echo "The ${i}th iteration failed to CURE. We expected some failure!" + fi + runit=0 + fi + fi + + # run it + if [ $runit != 0 ]; then + echo "./$tmpname$OUTEXT" + rm -f test-bad.out test-bad.err + if $CILHOME/bin/teetwo test-bad.out test-bad.err ./$tmpname$OUTEXT ; then + # cat test-bad.out test-bad.err + if [ $i = 0 ]; then + # expected success on 0th iteration + echo "(succeeded as expected)" + else + # unexpected success on >0th iteration + echo "The ${i}th iteration did not fail! It is supposed to fail." + exit 2 + fi + else + # cat test-bad.out test-bad.err + if [ $i = 0 ]; then + # unexpected failure on 0th iteration + echo "The 0th iteration failed! It is supposed to succeed." + #cat $tmpname.c + exit 2 + else + # expected failure on >0th iteration + if [ "x$themsg" != "x" ] ;then + echo "grep \"$themsg\" test-bad.out test-bad.err" + if ! grep "$themsg" test-bad.out test-bad.err ;then + echo "The ${i}th iteration failed but cannot find:$themsg" + exit 3 + fi + fi + echo "(failed as expected)" + fi + fi + fi + + # possibly bail after 0th + if [ "$TESTBADONCE" != "" ]; then + echo "bailing after 0th iteration because TESTBADONCE is set" + exit 0 + fi + if [ "$RUNONLY" != "" ]; then + echo "bailing after ${RUNONLY}th iteration because RUNONLY is set" + exit 0 + fi + + i=`expr $i + 1` +done + +echo "all $numcases cases in $srcfile failed as expected" + diff --git a/cil/cil.spec b/cil/cil.spec new file mode 100644 index 0000000..5380973 --- /dev/null +++ b/cil/cil.spec @@ -0,0 +1,90 @@ +Name: cil +Version: 1.3.5 +Release: 1 +License: BSD +URL: http://manju.cs.berkeley.edu/cil/ +Source0: %{name}-%{version}.tar.gz +BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-buildroot +BuildRequires: gcc +BuildRequires: ocaml >= 3.08 +BuildRequires: perl >= 5.6.1 + +# No ELF executables or shared libraries +%define debug_package %{nil} + + +######################################################################## +# +# Package cil +# + +Summary: OCaml library for C program analysis and transformation +Group: Development/Libraries +Requires: perl >= 5.6.1 + +%description +CIL (C Intermediate Language) is a high-level representation along +with a set of tools that permit easy analysis and source-to-source +transformation of C programs. + +This package provides Perl modules which are useful for building +compiler wrappers. A wrapper can use CIL to transform C code before +passing it along to the native C compiler. + +%files +%defattr(-,root,root,-) +%doc LICENSE +%{_datadir}/%{name} + + +######################################################################## +# +# Package cil-devel +# + +%package devel + +Summary: OCaml library for C program analysis and transformation +Group: Development/Libraries +Requires: ocaml >= 3.04 + +%description devel +CIL (C Intermediate Language) is a high-level representation along +with a set of tools that permit easy analysis and source-to-source +transformation of C programs. + +This package provides OCaml interfaces and an OCaml library which form +the CIL API. + +%files devel +%defattr(-,root,root,-) +%doc LICENSE +%{_libdir}/%{name} + + +######################################################################## +# +# General scripts +# + +%prep +%setup -q -n %{name} + +%build +%configure +%define cilmake make -f Makefile.cil +%cilmake cilversion machdep +%cilmake cillib NATIVECAML= +%cilmake cillib NATIVECAML=1 + +%install +rm -rf $RPM_BUILD_ROOT +%makeinstall + +%clean +rm -rf $RPM_BUILD_ROOT + + +%changelog +* Tue Aug 5 2003 Ben Liblit +- Initial build. diff --git a/cil/cil.spec.in b/cil/cil.spec.in new file mode 100644 index 0000000..0a47dbd --- /dev/null +++ b/cil/cil.spec.in @@ -0,0 +1,90 @@ +Name: cil +Version: @CIL_VERSION@ +Release: 1 +License: BSD +URL: http://manju.cs.berkeley.edu/cil/ +Source0: %{name}-%{version}.tar.gz +BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-buildroot +BuildRequires: gcc +BuildRequires: ocaml >= 3.08 +BuildRequires: perl >= 5.6.1 + +# No ELF executables or shared libraries +%define debug_package %{nil} + + +######################################################################## +# +# Package cil +# + +Summary: OCaml library for C program analysis and transformation +Group: Development/Libraries +Requires: perl >= 5.6.1 + +%description +CIL (C Intermediate Language) is a high-level representation along +with a set of tools that permit easy analysis and source-to-source +transformation of C programs. + +This package provides Perl modules which are useful for building +compiler wrappers. A wrapper can use CIL to transform C code before +passing it along to the native C compiler. + +%files +%defattr(-,root,root,-) +%doc LICENSE +%{_datadir}/%{name} + + +######################################################################## +# +# Package cil-devel +# + +%package devel + +Summary: OCaml library for C program analysis and transformation +Group: Development/Libraries +Requires: ocaml >= 3.04 + +%description devel +CIL (C Intermediate Language) is a high-level representation along +with a set of tools that permit easy analysis and source-to-source +transformation of C programs. + +This package provides OCaml interfaces and an OCaml library which form +the CIL API. + +%files devel +%defattr(-,root,root,-) +%doc LICENSE +%{_libdir}/%{name} + + +######################################################################## +# +# General scripts +# + +%prep +%setup -q -n %{name} + +%build +%configure +%define cilmake make -f Makefile.cil +%cilmake cilversion machdep +%cilmake cillib NATIVECAML= +%cilmake cillib NATIVECAML=1 + +%install +rm -rf $RPM_BUILD_ROOT +%makeinstall + +%clean +rm -rf $RPM_BUILD_ROOT + + +%changelog +* Tue Aug 5 2003 Ben Liblit +- Initial build. diff --git a/cil/config.guess b/cil/config.guess new file mode 100755 index 0000000..c085f4f --- /dev/null +++ b/cil/config.guess @@ -0,0 +1,1497 @@ +#! /bin/sh +# Attempt to guess a canonical system name. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, +# Inc. + +timestamp='2006-05-13' + +# This file is free software; you can redistribute it and/or modify it +# under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 51 Franklin Street - Fifth Floor, Boston, MA +# 02110-1301, USA. +# +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + + +# Originally written by Per Bothner . +# Please send patches to . Submit a context +# diff and a properly formatted ChangeLog entry. +# +# This script attempts to guess a canonical system name similar to +# config.sub. If it succeeds, it prints the system name on stdout, and +# exits with 0. Otherwise, it exits with 1. +# +# The plan is that this can be called by configure scripts if you +# don't specify an explicit build system type. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] + +Output the configuration name of the system \`$me' is run on. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.guess ($timestamp) + +Originally written by Per Bothner. +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005 +Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit ;; + --version | -v ) + echo "$version" ; exit ;; + --help | --h* | -h ) + echo "$usage"; exit ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" >&2 + exit 1 ;; + * ) + break ;; + esac +done + +if test $# != 0; then + echo "$me: too many arguments$help" >&2 + exit 1 +fi + +trap 'exit 1' 1 2 15 + +# CC_FOR_BUILD -- compiler used by this script. Note that the use of a +# compiler to aid in system detection is discouraged as it requires +# temporary files to be created and, as you can see below, it is a +# headache to deal with in a portable fashion. + +# Historically, `CC_FOR_BUILD' used to be named `HOST_CC'. We still +# use `HOST_CC' if defined, but it is deprecated. + +# Portable tmp directory creation inspired by the Autoconf team. + +set_cc_for_build=' +trap "exitcode=\$?; (rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null) && exit \$exitcode" 0 ; +trap "rm -f \$tmpfiles 2>/dev/null; rmdir \$tmp 2>/dev/null; exit 1" 1 2 13 15 ; +: ${TMPDIR=/tmp} ; + { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || + { test -n "$RANDOM" && tmp=$TMPDIR/cg$$-$RANDOM && (umask 077 && mkdir $tmp) ; } || + { tmp=$TMPDIR/cg-$$ && (umask 077 && mkdir $tmp) && echo "Warning: creating insecure temp directory" >&2 ; } || + { echo "$me: cannot create a temporary directory in $TMPDIR" >&2 ; exit 1 ; } ; +dummy=$tmp/dummy ; +tmpfiles="$dummy.c $dummy.o $dummy.rel $dummy" ; +case $CC_FOR_BUILD,$HOST_CC,$CC in + ,,) echo "int x;" > $dummy.c ; + for c in cc gcc c89 c99 ; do + if ($c -c -o $dummy.o $dummy.c) >/dev/null 2>&1 ; then + CC_FOR_BUILD="$c"; break ; + fi ; + done ; + if test x"$CC_FOR_BUILD" = x ; then + CC_FOR_BUILD=no_compiler_found ; + fi + ;; + ,,*) CC_FOR_BUILD=$CC ;; + ,*,*) CC_FOR_BUILD=$HOST_CC ;; +esac ; set_cc_for_build= ;' + +# This is needed to find uname on a Pyramid OSx when run in the BSD universe. +# (ghazi@noc.rutgers.edu 1994-08-24) +if (test -f /.attbin/uname) >/dev/null 2>&1 ; then + PATH=$PATH:/.attbin ; export PATH +fi + +UNAME_MACHINE=`(uname -m) 2>/dev/null` || UNAME_MACHINE=unknown +UNAME_RELEASE=`(uname -r) 2>/dev/null` || UNAME_RELEASE=unknown +UNAME_SYSTEM=`(uname -s) 2>/dev/null` || UNAME_SYSTEM=unknown +UNAME_VERSION=`(uname -v) 2>/dev/null` || UNAME_VERSION=unknown + +# Note: order is significant - the case branches are not exclusive. + +case "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" in + *:NetBSD:*:*) + # NetBSD (nbsd) targets should (where applicable) match one or + # more of the tupples: *-*-netbsdelf*, *-*-netbsdaout*, + # *-*-netbsdecoff* and *-*-netbsd*. For targets that recently + # switched to ELF, *-*-netbsd* would select the old + # object file format. This provides both forward + # compatibility and a consistent mechanism for selecting the + # object file format. + # + # Note: NetBSD doesn't particularly care about the vendor + # portion of the name. We always set it to "unknown". + sysctl="sysctl -n hw.machine_arch" + UNAME_MACHINE_ARCH=`(/sbin/$sysctl 2>/dev/null || \ + /usr/sbin/$sysctl 2>/dev/null || echo unknown)` + case "${UNAME_MACHINE_ARCH}" in + armeb) machine=armeb-unknown ;; + arm*) machine=arm-unknown ;; + sh3el) machine=shl-unknown ;; + sh3eb) machine=sh-unknown ;; + *) machine=${UNAME_MACHINE_ARCH}-unknown ;; + esac + # The Operating System including object format, if it has switched + # to ELF recently, or will in the future. + case "${UNAME_MACHINE_ARCH}" in + arm*|i386|m68k|ns32k|sh3*|sparc|vax) + eval $set_cc_for_build + if echo __ELF__ | $CC_FOR_BUILD -E - 2>/dev/null \ + | grep __ELF__ >/dev/null + then + # Once all utilities can be ECOFF (netbsdecoff) or a.out (netbsdaout). + # Return netbsd for either. FIX? + os=netbsd + else + os=netbsdelf + fi + ;; + *) + os=netbsd + ;; + esac + # The OS release + # Debian GNU/NetBSD machines have a different userland, and + # thus, need a distinct triplet. However, they do not need + # kernel version information, so it can be replaced with a + # suitable tag, in the style of linux-gnu. + case "${UNAME_VERSION}" in + Debian*) + release='-gnu' + ;; + *) + release=`echo ${UNAME_RELEASE}|sed -e 's/[-_].*/\./'` + ;; + esac + # Since CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM: + # contains redundant information, the shorter form: + # CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM is used. + echo "${machine}-${os}${release}" + exit ;; + *:OpenBSD:*:*) + UNAME_MACHINE_ARCH=`arch | sed 's/OpenBSD.//'` + echo ${UNAME_MACHINE_ARCH}-unknown-openbsd${UNAME_RELEASE} + exit ;; + *:ekkoBSD:*:*) + echo ${UNAME_MACHINE}-unknown-ekkobsd${UNAME_RELEASE} + exit ;; + *:SolidBSD:*:*) + echo ${UNAME_MACHINE}-unknown-solidbsd${UNAME_RELEASE} + exit ;; + macppc:MirBSD:*:*) + echo powerppc-unknown-mirbsd${UNAME_RELEASE} + exit ;; + *:MirBSD:*:*) + echo ${UNAME_MACHINE}-unknown-mirbsd${UNAME_RELEASE} + exit ;; + alpha:OSF1:*:*) + case $UNAME_RELEASE in + *4.0) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $3}'` + ;; + *5.*) + UNAME_RELEASE=`/usr/sbin/sizer -v | awk '{print $4}'` + ;; + esac + # According to Compaq, /usr/sbin/psrinfo has been available on + # OSF/1 and Tru64 systems produced since 1995. I hope that + # covers most systems running today. This code pipes the CPU + # types through head -n 1, so we only detect the type of CPU 0. + ALPHA_CPU_TYPE=`/usr/sbin/psrinfo -v | sed -n -e 's/^ The alpha \(.*\) processor.*$/\1/p' | head -n 1` + case "$ALPHA_CPU_TYPE" in + "EV4 (21064)") + UNAME_MACHINE="alpha" ;; + "EV4.5 (21064)") + UNAME_MACHINE="alpha" ;; + "LCA4 (21066/21068)") + UNAME_MACHINE="alpha" ;; + "EV5 (21164)") + UNAME_MACHINE="alphaev5" ;; + "EV5.6 (21164A)") + UNAME_MACHINE="alphaev56" ;; + "EV5.6 (21164PC)") + UNAME_MACHINE="alphapca56" ;; + "EV5.7 (21164PC)") + UNAME_MACHINE="alphapca57" ;; + "EV6 (21264)") + UNAME_MACHINE="alphaev6" ;; + "EV6.7 (21264A)") + UNAME_MACHINE="alphaev67" ;; + "EV6.8CB (21264C)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8AL (21264B)") + UNAME_MACHINE="alphaev68" ;; + "EV6.8CX (21264D)") + UNAME_MACHINE="alphaev68" ;; + "EV6.9A (21264/EV69A)") + UNAME_MACHINE="alphaev69" ;; + "EV7 (21364)") + UNAME_MACHINE="alphaev7" ;; + "EV7.9 (21364A)") + UNAME_MACHINE="alphaev79" ;; + esac + # A Pn.n version is a patched version. + # A Vn.n version is a released version. + # A Tn.n version is a released field test version. + # A Xn.n version is an unreleased experimental baselevel. + # 1.2 uses "1.2" for uname -r. + echo ${UNAME_MACHINE}-dec-osf`echo ${UNAME_RELEASE} | sed -e 's/^[PVTX]//' | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + exit ;; + Alpha\ *:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # Should we change UNAME_MACHINE based on the output of uname instead + # of the specific Alpha model? + echo alpha-pc-interix + exit ;; + 21064:Windows_NT:50:3) + echo alpha-dec-winnt3.5 + exit ;; + Amiga*:UNIX_System_V:4.0:*) + echo m68k-unknown-sysv4 + exit ;; + *:[Aa]miga[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-amigaos + exit ;; + *:[Mm]orph[Oo][Ss]:*:*) + echo ${UNAME_MACHINE}-unknown-morphos + exit ;; + *:OS/390:*:*) + echo i370-ibm-openedition + exit ;; + *:z/VM:*:*) + echo s390-ibm-zvmoe + exit ;; + *:OS400:*:*) + echo powerpc-ibm-os400 + exit ;; + arm:RISC*:1.[012]*:*|arm:riscix:1.[012]*:*) + echo arm-acorn-riscix${UNAME_RELEASE} + exit ;; + arm:riscos:*:*|arm:RISCOS:*:*) + echo arm-unknown-riscos + exit ;; + SR2?01:HI-UX/MPP:*:* | SR8000:HI-UX/MPP:*:*) + echo hppa1.1-hitachi-hiuxmpp + exit ;; + Pyramid*:OSx*:*:* | MIS*:OSx*:*:* | MIS*:SMP_DC-OSx*:*:*) + # akee@wpdis03.wpafb.af.mil (Earle F. Ake) contributed MIS and NILE. + if test "`(/bin/universe) 2>/dev/null`" = att ; then + echo pyramid-pyramid-sysv3 + else + echo pyramid-pyramid-bsd + fi + exit ;; + NILE*:*:*:dcosx) + echo pyramid-pyramid-svr4 + exit ;; + DRS?6000:unix:4.0:6*) + echo sparc-icl-nx6 + exit ;; + DRS?6000:UNIX_SV:4.2*:7* | DRS?6000:isis:4.2*:7*) + case `/usr/bin/uname -p` in + sparc) echo sparc-icl-nx7; exit ;; + esac ;; + sun4H:SunOS:5.*:*) + echo sparc-hal-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:5.*:* | tadpole*:SunOS:5.*:*) + echo sparc-sun-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + i86pc:SunOS:5.*:*) + echo i386-pc-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:6*:*) + # According to config.sub, this is the proper way to canonicalize + # SunOS6. Hard to guess exactly what SunOS6 will be like, but + # it's likely to be more like Solaris than SunOS4. + echo sparc-sun-solaris3`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + sun4*:SunOS:*:*) + case "`/usr/bin/arch -k`" in + Series*|S4*) + UNAME_RELEASE=`uname -v` + ;; + esac + # Japanese Language versions have a version number like `4.1.3-JL'. + echo sparc-sun-sunos`echo ${UNAME_RELEASE}|sed -e 's/-/_/'` + exit ;; + sun3*:SunOS:*:*) + echo m68k-sun-sunos${UNAME_RELEASE} + exit ;; + sun*:*:4.2BSD:*) + UNAME_RELEASE=`(sed 1q /etc/motd | awk '{print substr($5,1,3)}') 2>/dev/null` + test "x${UNAME_RELEASE}" = "x" && UNAME_RELEASE=3 + case "`/bin/arch`" in + sun3) + echo m68k-sun-sunos${UNAME_RELEASE} + ;; + sun4) + echo sparc-sun-sunos${UNAME_RELEASE} + ;; + esac + exit ;; + aushp:SunOS:*:*) + echo sparc-auspex-sunos${UNAME_RELEASE} + exit ;; + # The situation for MiNT is a little confusing. The machine name + # can be virtually everything (everything which is not + # "atarist" or "atariste" at least should have a processor + # > m68000). The system name ranges from "MiNT" over "FreeMiNT" + # to the lowercase version "mint" (or "freemint"). Finally + # the system name "TOS" denotes a system which is actually not + # MiNT. But MiNT is downward compatible to TOS, so this should + # be no problem. + atarist[e]:*MiNT:*:* | atarist[e]:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + atari*:*MiNT:*:* | atari*:*mint:*:* | atarist[e]:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + *falcon*:*MiNT:*:* | *falcon*:*mint:*:* | *falcon*:*TOS:*:*) + echo m68k-atari-mint${UNAME_RELEASE} + exit ;; + milan*:*MiNT:*:* | milan*:*mint:*:* | *milan*:*TOS:*:*) + echo m68k-milan-mint${UNAME_RELEASE} + exit ;; + hades*:*MiNT:*:* | hades*:*mint:*:* | *hades*:*TOS:*:*) + echo m68k-hades-mint${UNAME_RELEASE} + exit ;; + *:*MiNT:*:* | *:*mint:*:* | *:*TOS:*:*) + echo m68k-unknown-mint${UNAME_RELEASE} + exit ;; + m68k:machten:*:*) + echo m68k-apple-machten${UNAME_RELEASE} + exit ;; + powerpc:machten:*:*) + echo powerpc-apple-machten${UNAME_RELEASE} + exit ;; + RISC*:Mach:*:*) + echo mips-dec-mach_bsd4.3 + exit ;; + RISC*:ULTRIX:*:*) + echo mips-dec-ultrix${UNAME_RELEASE} + exit ;; + VAX*:ULTRIX*:*:*) + echo vax-dec-ultrix${UNAME_RELEASE} + exit ;; + 2020:CLIX:*:* | 2430:CLIX:*:*) + echo clipper-intergraph-clix${UNAME_RELEASE} + exit ;; + mips:*:*:UMIPS | mips:*:*:RISCos) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c +#ifdef __cplusplus +#include /* for printf() prototype */ + int main (int argc, char *argv[]) { +#else + int main (argc, argv) int argc; char *argv[]; { +#endif + #if defined (host_mips) && defined (MIPSEB) + #if defined (SYSTYPE_SYSV) + printf ("mips-mips-riscos%ssysv\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_SVR4) + printf ("mips-mips-riscos%ssvr4\n", argv[1]); exit (0); + #endif + #if defined (SYSTYPE_BSD43) || defined(SYSTYPE_BSD) + printf ("mips-mips-riscos%sbsd\n", argv[1]); exit (0); + #endif + #endif + exit (-1); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && + dummyarg=`echo "${UNAME_RELEASE}" | sed -n 's/\([0-9]*\).*/\1/p'` && + SYSTEM_NAME=`$dummy $dummyarg` && + { echo "$SYSTEM_NAME"; exit; } + echo mips-mips-riscos${UNAME_RELEASE} + exit ;; + Motorola:PowerMAX_OS:*:*) + echo powerpc-motorola-powermax + exit ;; + Motorola:*:4.3:PL8-*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:*:*:PowerMAX_OS | Synergy:PowerMAX_OS:*:*) + echo powerpc-harris-powermax + exit ;; + Night_Hawk:Power_UNIX:*:*) + echo powerpc-harris-powerunix + exit ;; + m88k:CX/UX:7*:*) + echo m88k-harris-cxux7 + exit ;; + m88k:*:4*:R4*) + echo m88k-motorola-sysv4 + exit ;; + m88k:*:3*:R3*) + echo m88k-motorola-sysv3 + exit ;; + AViiON:dgux:*:*) + # DG/UX returns AViiON for all architectures + UNAME_PROCESSOR=`/usr/bin/uname -p` + if [ $UNAME_PROCESSOR = mc88100 ] || [ $UNAME_PROCESSOR = mc88110 ] + then + if [ ${TARGET_BINARY_INTERFACE}x = m88kdguxelfx ] || \ + [ ${TARGET_BINARY_INTERFACE}x = x ] + then + echo m88k-dg-dgux${UNAME_RELEASE} + else + echo m88k-dg-dguxbcs${UNAME_RELEASE} + fi + else + echo i586-dg-dgux${UNAME_RELEASE} + fi + exit ;; + M88*:DolphinOS:*:*) # DolphinOS (SVR3) + echo m88k-dolphin-sysv3 + exit ;; + M88*:*:R3*:*) + # Delta 88k system running SVR3 + echo m88k-motorola-sysv3 + exit ;; + XD88*:*:*:*) # Tektronix XD88 system running UTekV (SVR3) + echo m88k-tektronix-sysv3 + exit ;; + Tek43[0-9][0-9]:UTek:*:*) # Tektronix 4300 system running UTek (BSD) + echo m68k-tektronix-bsd + exit ;; + *:IRIX*:*:*) + echo mips-sgi-irix`echo ${UNAME_RELEASE}|sed -e 's/-/_/g'` + exit ;; + ????????:AIX?:[12].1:2) # AIX 2.2.1 or AIX 2.1.1 is RT/PC AIX. + echo romp-ibm-aix # uname -m gives an 8 hex-code CPU id + exit ;; # Note that: echo "'`uname -s`'" gives 'AIX ' + i*86:AIX:*:*) + echo i386-ibm-aix + exit ;; + ia64:AIX:*:*) + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${UNAME_MACHINE}-ibm-aix${IBM_REV} + exit ;; + *:AIX:2:3) + if grep bos325 /usr/include/stdio.h >/dev/null 2>&1; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + + main() + { + if (!__power_pc()) + exit(1); + puts("powerpc-ibm-aix3.2.5"); + exit(0); + } +EOF + if $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` + then + echo "$SYSTEM_NAME" + else + echo rs6000-ibm-aix3.2.5 + fi + elif grep bos324 /usr/include/stdio.h >/dev/null 2>&1; then + echo rs6000-ibm-aix3.2.4 + else + echo rs6000-ibm-aix3.2 + fi + exit ;; + *:AIX:*:[45]) + IBM_CPU_ID=`/usr/sbin/lsdev -C -c processor -S available | sed 1q | awk '{ print $1 }'` + if /usr/sbin/lsattr -El ${IBM_CPU_ID} | grep ' POWER' >/dev/null 2>&1; then + IBM_ARCH=rs6000 + else + IBM_ARCH=powerpc + fi + if [ -x /usr/bin/oslevel ] ; then + IBM_REV=`/usr/bin/oslevel` + else + IBM_REV=${UNAME_VERSION}.${UNAME_RELEASE} + fi + echo ${IBM_ARCH}-ibm-aix${IBM_REV} + exit ;; + *:AIX:*:*) + echo rs6000-ibm-aix + exit ;; + ibmrt:4.4BSD:*|romp-ibm:BSD:*) + echo romp-ibm-bsd4.4 + exit ;; + ibmrt:*BSD:*|romp-ibm:BSD:*) # covers RT/PC BSD and + echo romp-ibm-bsd${UNAME_RELEASE} # 4.3 with uname added to + exit ;; # report: romp-ibm BSD 4.3 + *:BOSX:*:*) + echo rs6000-bull-bosx + exit ;; + DPX/2?00:B.O.S.:*:*) + echo m68k-bull-sysv3 + exit ;; + 9000/[34]??:4.3bsd:1.*:*) + echo m68k-hp-bsd + exit ;; + hp300:4.4BSD:*:* | 9000/[34]??:4.3bsd:2.*:*) + echo m68k-hp-bsd4.4 + exit ;; + 9000/[34678]??:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + case "${UNAME_MACHINE}" in + 9000/31? ) HP_ARCH=m68000 ;; + 9000/[34]?? ) HP_ARCH=m68k ;; + 9000/[678][0-9][0-9]) + if [ -x /usr/bin/getconf ]; then + sc_cpu_version=`/usr/bin/getconf SC_CPU_VERSION 2>/dev/null` + sc_kernel_bits=`/usr/bin/getconf SC_KERNEL_BITS 2>/dev/null` + case "${sc_cpu_version}" in + 523) HP_ARCH="hppa1.0" ;; # CPU_PA_RISC1_0 + 528) HP_ARCH="hppa1.1" ;; # CPU_PA_RISC1_1 + 532) # CPU_PA_RISC2_0 + case "${sc_kernel_bits}" in + 32) HP_ARCH="hppa2.0n" ;; + 64) HP_ARCH="hppa2.0w" ;; + '') HP_ARCH="hppa2.0" ;; # HP-UX 10.20 + esac ;; + esac + fi + if [ "${HP_ARCH}" = "" ]; then + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + + #define _HPUX_SOURCE + #include + #include + + int main () + { + #if defined(_SC_KERNEL_BITS) + long bits = sysconf(_SC_KERNEL_BITS); + #endif + long cpu = sysconf (_SC_CPU_VERSION); + + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1"); break; + case CPU_PA_RISC2_0: + #if defined(_SC_KERNEL_BITS) + switch (bits) + { + case 64: puts ("hppa2.0w"); break; + case 32: puts ("hppa2.0n"); break; + default: puts ("hppa2.0"); break; + } break; + #else /* !defined(_SC_KERNEL_BITS) */ + puts ("hppa2.0"); break; + #endif + default: puts ("hppa1.0"); break; + } + exit (0); + } +EOF + (CCOPTS= $CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null) && HP_ARCH=`$dummy` + test -z "$HP_ARCH" && HP_ARCH=hppa + fi ;; + esac + if [ ${HP_ARCH} = "hppa2.0w" ] + then + eval $set_cc_for_build + + # hppa2.0w-hp-hpux* has a 64-bit kernel and a compiler generating + # 32-bit code. hppa64-hp-hpux* has the same kernel and a compiler + # generating 64-bit code. GNU and HP use different nomenclature: + # + # $ CC_FOR_BUILD=cc ./config.guess + # => hppa2.0w-hp-hpux11.23 + # $ CC_FOR_BUILD="cc +DA2.0w" ./config.guess + # => hppa64-hp-hpux11.23 + + if echo __LP64__ | (CCOPTS= $CC_FOR_BUILD -E - 2>/dev/null) | + grep __LP64__ >/dev/null + then + HP_ARCH="hppa2.0w" + else + HP_ARCH="hppa64" + fi + fi + echo ${HP_ARCH}-hp-hpux${HPUX_REV} + exit ;; + ia64:HP-UX:*:*) + HPUX_REV=`echo ${UNAME_RELEASE}|sed -e 's/[^.]*.[0B]*//'` + echo ia64-hp-hpux${HPUX_REV} + exit ;; + 3050*:HI-UX:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + int + main () + { + long cpu = sysconf (_SC_CPU_VERSION); + /* The order matters, because CPU_IS_HP_MC68K erroneously returns + true for CPU_PA_RISC1_0. CPU_IS_PA_RISC returns correct + results, however. */ + if (CPU_IS_PA_RISC (cpu)) + { + switch (cpu) + { + case CPU_PA_RISC1_0: puts ("hppa1.0-hitachi-hiuxwe2"); break; + case CPU_PA_RISC1_1: puts ("hppa1.1-hitachi-hiuxwe2"); break; + case CPU_PA_RISC2_0: puts ("hppa2.0-hitachi-hiuxwe2"); break; + default: puts ("hppa-hitachi-hiuxwe2"); break; + } + } + else if (CPU_IS_HP_MC68K (cpu)) + puts ("m68k-hitachi-hiuxwe2"); + else puts ("unknown-hitachi-hiuxwe2"); + exit (0); + } +EOF + $CC_FOR_BUILD -o $dummy $dummy.c && SYSTEM_NAME=`$dummy` && + { echo "$SYSTEM_NAME"; exit; } + echo unknown-hitachi-hiuxwe2 + exit ;; + 9000/7??:4.3bsd:*:* | 9000/8?[79]:4.3bsd:*:* ) + echo hppa1.1-hp-bsd + exit ;; + 9000/8??:4.3bsd:*:*) + echo hppa1.0-hp-bsd + exit ;; + *9??*:MPE/iX:*:* | *3000*:MPE/iX:*:*) + echo hppa1.0-hp-mpeix + exit ;; + hp7??:OSF1:*:* | hp8?[79]:OSF1:*:* ) + echo hppa1.1-hp-osf + exit ;; + hp8??:OSF1:*:*) + echo hppa1.0-hp-osf + exit ;; + i*86:OSF1:*:*) + if [ -x /usr/sbin/sysversion ] ; then + echo ${UNAME_MACHINE}-unknown-osf1mk + else + echo ${UNAME_MACHINE}-unknown-osf1 + fi + exit ;; + parisc*:Lites*:*:*) + echo hppa1.1-hp-lites + exit ;; + C1*:ConvexOS:*:* | convex:ConvexOS:C1*:*) + echo c1-convex-bsd + exit ;; + C2*:ConvexOS:*:* | convex:ConvexOS:C2*:*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit ;; + C34*:ConvexOS:*:* | convex:ConvexOS:C34*:*) + echo c34-convex-bsd + exit ;; + C38*:ConvexOS:*:* | convex:ConvexOS:C38*:*) + echo c38-convex-bsd + exit ;; + C4*:ConvexOS:*:* | convex:ConvexOS:C4*:*) + echo c4-convex-bsd + exit ;; + CRAY*Y-MP:*:*:*) + echo ymp-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*[A-Z]90:*:*:*) + echo ${UNAME_MACHINE}-cray-unicos${UNAME_RELEASE} \ + | sed -e 's/CRAY.*\([A-Z]90\)/\1/' \ + -e y/ABCDEFGHIJKLMNOPQRSTUVWXYZ/abcdefghijklmnopqrstuvwxyz/ \ + -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*TS:*:*:*) + echo t90-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*T3E:*:*:*) + echo alphaev5-cray-unicosmk${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + CRAY*SV1:*:*:*) + echo sv1-cray-unicos${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + *:UNICOS/mp:*:*) + echo craynv-cray-unicosmp${UNAME_RELEASE} | sed -e 's/\.[^.]*$/.X/' + exit ;; + F30[01]:UNIX_System_V:*:* | F700:UNIX_System_V:*:*) + FUJITSU_PROC=`uname -m | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz'` + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | sed -e 's/ /_/'` + echo "${FUJITSU_PROC}-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + 5000:UNIX_System_V:4.*:*) + FUJITSU_SYS=`uname -p | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/\///'` + FUJITSU_REL=`echo ${UNAME_RELEASE} | tr 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' 'abcdefghijklmnopqrstuvwxyz' | sed -e 's/ /_/'` + echo "sparc-fujitsu-${FUJITSU_SYS}${FUJITSU_REL}" + exit ;; + i*86:BSD/386:*:* | i*86:BSD/OS:*:* | *:Ascend\ Embedded/OS:*:*) + echo ${UNAME_MACHINE}-pc-bsdi${UNAME_RELEASE} + exit ;; + sparc*:BSD/OS:*:*) + echo sparc-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:BSD/OS:*:*) + echo ${UNAME_MACHINE}-unknown-bsdi${UNAME_RELEASE} + exit ;; + *:FreeBSD:*:*) + case ${UNAME_MACHINE} in + pc98) + echo i386-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + amd64) + echo x86_64-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + *) + echo ${UNAME_MACHINE}-unknown-freebsd`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` ;; + esac + exit ;; + i*:CYGWIN*:*) + echo ${UNAME_MACHINE}-pc-cygwin + exit ;; + i*:MINGW*:*) + echo ${UNAME_MACHINE}-pc-mingw32 + exit ;; + i*:windows32*:*) + # uname -m includes "-pc" on this system. + echo ${UNAME_MACHINE}-mingw32 + exit ;; + i*:PW*:*) + echo ${UNAME_MACHINE}-pc-pw32 + exit ;; + x86:Interix*:[345]*) + echo i586-pc-interix${UNAME_RELEASE} + exit ;; + EM64T:Interix*:[345]*) + echo x86_64-unknown-interix${UNAME_RELEASE} + exit ;; + [345]86:Windows_95:* | [345]86:Windows_98:* | [345]86:Windows_NT:*) + echo i${UNAME_MACHINE}-pc-mks + exit ;; + i*:Windows_NT*:* | Pentium*:Windows_NT*:*) + # How do we know it's Interix rather than the generic POSIX subsystem? + # It also conflicts with pre-2.0 versions of AT&T UWIN. Should we + # UNAME_MACHINE based on the output of uname instead of i386? + echo i586-pc-interix + exit ;; + i*:UWIN*:*) + echo ${UNAME_MACHINE}-pc-uwin + exit ;; + amd64:CYGWIN*:*:* | x86_64:CYGWIN*:*:*) + echo x86_64-unknown-cygwin + exit ;; + p*:CYGWIN*:*) + echo powerpcle-unknown-cygwin + exit ;; + prep*:SunOS:5.*:*) + echo powerpcle-unknown-solaris2`echo ${UNAME_RELEASE}|sed -e 's/[^.]*//'` + exit ;; + *:GNU:*:*) + # the GNU system + echo `echo ${UNAME_MACHINE}|sed -e 's,[-/].*$,,'`-unknown-gnu`echo ${UNAME_RELEASE}|sed -e 's,/.*$,,'` + exit ;; + *:GNU/*:*:*) + # other systems with GNU libc and userland + echo ${UNAME_MACHINE}-unknown-`echo ${UNAME_SYSTEM} | sed 's,^[^/]*/,,' | tr '[A-Z]' '[a-z]'``echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'`-gnu + exit ;; + i*86:Minix:*:*) + echo ${UNAME_MACHINE}-pc-minix + exit ;; + arm*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + cris:Linux:*:*) + echo cris-axis-linux-gnu + exit ;; + crisv32:Linux:*:*) + echo crisv32-axis-linux-gnu + exit ;; + frv:Linux:*:*) + echo frv-unknown-linux-gnu + exit ;; + ia64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + m32r*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + m68*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + mips:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef mips + #undef mipsel + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=mipsel + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=mips + #else + CPU= + #endif + #endif +EOF + eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' + /^CPU/{ + s: ::g + p + }'`" + test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } + ;; + mips64:Linux:*:*) + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #undef CPU + #undef mips64 + #undef mips64el + #if defined(__MIPSEL__) || defined(__MIPSEL) || defined(_MIPSEL) || defined(MIPSEL) + CPU=mips64el + #else + #if defined(__MIPSEB__) || defined(__MIPSEB) || defined(_MIPSEB) || defined(MIPSEB) + CPU=mips64 + #else + CPU= + #endif + #endif +EOF + eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' + /^CPU/{ + s: ::g + p + }'`" + test x"${CPU}" != x && { echo "${CPU}-unknown-linux-gnu"; exit; } + ;; + or32:Linux:*:*) + echo or32-unknown-linux-gnu + exit ;; + ppc:Linux:*:*) + echo powerpc-unknown-linux-gnu + exit ;; + ppc64:Linux:*:*) + echo powerpc64-unknown-linux-gnu + exit ;; + alpha:Linux:*:*) + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + EV5) UNAME_MACHINE=alphaev5 ;; + EV56) UNAME_MACHINE=alphaev56 ;; + PCA56) UNAME_MACHINE=alphapca56 ;; + PCA57) UNAME_MACHINE=alphapca56 ;; + EV6) UNAME_MACHINE=alphaev6 ;; + EV67) UNAME_MACHINE=alphaev67 ;; + EV68*) UNAME_MACHINE=alphaev68 ;; + esac + objdump --private-headers /bin/sh | grep ld.so.1 >/dev/null + if test "$?" = 0 ; then LIBC="libc1" ; else LIBC="" ; fi + echo ${UNAME_MACHINE}-unknown-linux-gnu${LIBC} + exit ;; + parisc:Linux:*:* | hppa:Linux:*:*) + # Look for CPU level + case `grep '^cpu[^a-z]*:' /proc/cpuinfo 2>/dev/null | cut -d' ' -f2` in + PA7*) echo hppa1.1-unknown-linux-gnu ;; + PA8*) echo hppa2.0-unknown-linux-gnu ;; + *) echo hppa-unknown-linux-gnu ;; + esac + exit ;; + parisc64:Linux:*:* | hppa64:Linux:*:*) + echo hppa64-unknown-linux-gnu + exit ;; + s390:Linux:*:* | s390x:Linux:*:*) + echo ${UNAME_MACHINE}-ibm-linux + exit ;; + sh64*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + sh*:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + sparc:Linux:*:* | sparc64:Linux:*:*) + echo ${UNAME_MACHINE}-unknown-linux-gnu + exit ;; + vax:Linux:*:*) + echo ${UNAME_MACHINE}-dec-linux-gnu + exit ;; + x86_64:Linux:*:*) + echo x86_64-unknown-linux-gnu + exit ;; + i*86:Linux:*:*) + # The BFD linker knows what the default object file format is, so + # first see if it will tell us. cd to the root directory to prevent + # problems with other programs or directories called `ld' in the path. + # Set LC_ALL=C to ensure ld outputs messages in English. + ld_supported_targets=`cd /; LC_ALL=C ld --help 2>&1 \ + | sed -ne '/supported targets:/!d + s/[ ][ ]*/ /g + s/.*supported targets: *// + s/ .*// + p'` + case "$ld_supported_targets" in + elf32-i386) + TENTATIVE="${UNAME_MACHINE}-pc-linux-gnu" + ;; + a.out-i386-linux) + echo "${UNAME_MACHINE}-pc-linux-gnuaout" + exit ;; + coff-i386) + echo "${UNAME_MACHINE}-pc-linux-gnucoff" + exit ;; + "") + # Either a pre-BFD a.out linker (linux-gnuoldld) or + # one that does not give us useful --help. + echo "${UNAME_MACHINE}-pc-linux-gnuoldld" + exit ;; + esac + # Determine whether the default compiler is a.out or elf + eval $set_cc_for_build + sed 's/^ //' << EOF >$dummy.c + #include + #ifdef __ELF__ + # ifdef __GLIBC__ + # if __GLIBC__ >= 2 + LIBC=gnu + # else + LIBC=gnulibc1 + # endif + # else + LIBC=gnulibc1 + # endif + #else + #if defined(__INTEL_COMPILER) || defined(__PGI) || defined(__SUNPRO_C) || defined(__SUNPRO_CC) + LIBC=gnu + #else + LIBC=gnuaout + #endif + #endif + #ifdef __dietlibc__ + LIBC=dietlibc + #endif +EOF + eval "`$CC_FOR_BUILD -E $dummy.c 2>/dev/null | sed -n ' + /^LIBC/{ + s: ::g + p + }'`" + test x"${LIBC}" != x && { + echo "${UNAME_MACHINE}-pc-linux-${LIBC}" + exit + } + test x"${TENTATIVE}" != x && { echo "${TENTATIVE}"; exit; } + ;; + i*86:DYNIX/ptx:4*:*) + # ptx 4.0 does uname -s correctly, with DYNIX/ptx in there. + # earlier versions are messed up and put the nodename in both + # sysname and nodename. + echo i386-sequent-sysv4 + exit ;; + i*86:UNIX_SV:4.2MP:2.*) + # Unixware is an offshoot of SVR4, but it has its own version + # number series starting with 2... + # I am not positive that other SVR4 systems won't match this, + # I just have to hope. -- rms. + # Use sysv4.2uw... so that sysv4* matches it. + echo ${UNAME_MACHINE}-pc-sysv4.2uw${UNAME_VERSION} + exit ;; + i*86:OS/2:*:*) + # If we were able to find `uname', then EMX Unix compatibility + # is probably installed. + echo ${UNAME_MACHINE}-pc-os2-emx + exit ;; + i*86:XTS-300:*:STOP) + echo ${UNAME_MACHINE}-unknown-stop + exit ;; + i*86:atheos:*:*) + echo ${UNAME_MACHINE}-unknown-atheos + exit ;; + i*86:syllable:*:*) + echo ${UNAME_MACHINE}-pc-syllable + exit ;; + i*86:LynxOS:2.*:* | i*86:LynxOS:3.[01]*:* | i*86:LynxOS:4.0*:*) + echo i386-unknown-lynxos${UNAME_RELEASE} + exit ;; + i*86:*DOS:*:*) + echo ${UNAME_MACHINE}-pc-msdosdjgpp + exit ;; + i*86:*:4.*:* | i*86:SYSTEM_V:4.*:*) + UNAME_REL=`echo ${UNAME_RELEASE} | sed 's/\/MP$//'` + if grep Novell /usr/include/link.h >/dev/null 2>/dev/null; then + echo ${UNAME_MACHINE}-univel-sysv${UNAME_REL} + else + echo ${UNAME_MACHINE}-pc-sysv${UNAME_REL} + fi + exit ;; + i*86:*:5:[678]*) + # UnixWare 7.x, OpenUNIX and OpenServer 6. + case `/bin/uname -X | grep "^Machine"` in + *486*) UNAME_MACHINE=i486 ;; + *Pentium) UNAME_MACHINE=i586 ;; + *Pent*|*Celeron) UNAME_MACHINE=i686 ;; + esac + echo ${UNAME_MACHINE}-unknown-sysv${UNAME_RELEASE}${UNAME_SYSTEM}${UNAME_VERSION} + exit ;; + i*86:*:3.2:*) + if test -f /usr/options/cb.name; then + UNAME_REL=`sed -n 's/.*Version //p' /dev/null >/dev/null ; then + UNAME_REL=`(/bin/uname -X|grep Release|sed -e 's/.*= //')` + (/bin/uname -X|grep i80486 >/dev/null) && UNAME_MACHINE=i486 + (/bin/uname -X|grep '^Machine.*Pentium' >/dev/null) \ + && UNAME_MACHINE=i586 + (/bin/uname -X|grep '^Machine.*Pent *II' >/dev/null) \ + && UNAME_MACHINE=i686 + (/bin/uname -X|grep '^Machine.*Pentium Pro' >/dev/null) \ + && UNAME_MACHINE=i686 + echo ${UNAME_MACHINE}-pc-sco$UNAME_REL + else + echo ${UNAME_MACHINE}-pc-sysv32 + fi + exit ;; + pc:*:*:*) + # Left here for compatibility: + # uname -m prints for DJGPP always 'pc', but it prints nothing about + # the processor, so we play safe by assuming i386. + echo i386-pc-msdosdjgpp + exit ;; + Intel:Mach:3*:*) + echo i386-pc-mach3 + exit ;; + paragon:*:*:*) + echo i860-intel-osf1 + exit ;; + i860:*:4.*:*) # i860-SVR4 + if grep Stardent /usr/include/sys/uadmin.h >/dev/null 2>&1 ; then + echo i860-stardent-sysv${UNAME_RELEASE} # Stardent Vistra i860-SVR4 + else # Add other i860-SVR4 vendors below as they are discovered. + echo i860-unknown-sysv${UNAME_RELEASE} # Unknown i860-SVR4 + fi + exit ;; + mini*:CTIX:SYS*5:*) + # "miniframe" + echo m68010-convergent-sysv + exit ;; + mc68k:UNIX:SYSTEM5:3.51m) + echo m68k-convergent-sysv + exit ;; + M680?0:D-NIX:5.3:*) + echo m68k-diab-dnix + exit ;; + M68*:*:R3V[5678]*:*) + test -r /sysV68 && { echo 'm68k-motorola-sysv'; exit; } ;; + 3[345]??:*:4.0:3.0 | 3[34]??A:*:4.0:3.0 | 3[34]??,*:*:4.0:3.0 | 3[34]??/*:*:4.0:3.0 | 4400:*:4.0:3.0 | 4850:*:4.0:3.0 | SKA40:*:4.0:3.0 | SDS2:*:4.0:3.0 | SHG2:*:4.0:3.0 | S7501*:*:4.0:3.0) + OS_REL='' + test -r /etc/.relid \ + && OS_REL=.`sed -n 's/[^ ]* [^ ]* \([0-9][0-9]\).*/\1/p' < /etc/.relid` + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4.3${OS_REL}; exit; } + /bin/uname -p 2>/dev/null | /bin/grep entium >/dev/null \ + && { echo i586-ncr-sysv4.3${OS_REL}; exit; } ;; + 3[34]??:*:4.0:* | 3[34]??,*:*:4.0:*) + /bin/uname -p 2>/dev/null | grep 86 >/dev/null \ + && { echo i486-ncr-sysv4; exit; } ;; + m68*:LynxOS:2.*:* | m68*:LynxOS:3.0*:*) + echo m68k-unknown-lynxos${UNAME_RELEASE} + exit ;; + mc68030:UNIX_System_V:4.*:*) + echo m68k-atari-sysv4 + exit ;; + TSUNAMI:LynxOS:2.*:*) + echo sparc-unknown-lynxos${UNAME_RELEASE} + exit ;; + rs6000:LynxOS:2.*:*) + echo rs6000-unknown-lynxos${UNAME_RELEASE} + exit ;; + PowerPC:LynxOS:2.*:* | PowerPC:LynxOS:3.[01]*:* | PowerPC:LynxOS:4.0*:*) + echo powerpc-unknown-lynxos${UNAME_RELEASE} + exit ;; + SM[BE]S:UNIX_SV:*:*) + echo mips-dde-sysv${UNAME_RELEASE} + exit ;; + RM*:ReliantUNIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + RM*:SINIX-*:*:*) + echo mips-sni-sysv4 + exit ;; + *:SINIX-*:*:*) + if uname -p 2>/dev/null >/dev/null ; then + UNAME_MACHINE=`(uname -p) 2>/dev/null` + echo ${UNAME_MACHINE}-sni-sysv4 + else + echo ns32k-sni-sysv + fi + exit ;; + PENTIUM:*:4.0*:*) # Unisys `ClearPath HMP IX 4000' SVR4/MP effort + # says + echo i586-unisys-sysv4 + exit ;; + *:UNIX_System_V:4*:FTX*) + # From Gerald Hewes . + # How about differentiating between stratus architectures? -djm + echo hppa1.1-stratus-sysv4 + exit ;; + *:*:*:FTX*) + # From seanf@swdc.stratus.com. + echo i860-stratus-sysv4 + exit ;; + i*86:VOS:*:*) + # From Paul.Green@stratus.com. + echo ${UNAME_MACHINE}-stratus-vos + exit ;; + *:VOS:*:*) + # From Paul.Green@stratus.com. + echo hppa1.1-stratus-vos + exit ;; + mc68*:A/UX:*:*) + echo m68k-apple-aux${UNAME_RELEASE} + exit ;; + news*:NEWS-OS:6*:*) + echo mips-sony-newsos6 + exit ;; + R[34]000:*System_V*:*:* | R4000:UNIX_SYSV:*:* | R*000:UNIX_SV:*:*) + if [ -d /usr/nec ]; then + echo mips-nec-sysv${UNAME_RELEASE} + else + echo mips-unknown-sysv${UNAME_RELEASE} + fi + exit ;; + BeBox:BeOS:*:*) # BeOS running on hardware made by Be, PPC only. + echo powerpc-be-beos + exit ;; + BeMac:BeOS:*:*) # BeOS running on Mac or Mac clone, PPC only. + echo powerpc-apple-beos + exit ;; + BePC:BeOS:*:*) # BeOS running on Intel PC compatible. + echo i586-pc-beos + exit ;; + SX-4:SUPER-UX:*:*) + echo sx4-nec-superux${UNAME_RELEASE} + exit ;; + SX-5:SUPER-UX:*:*) + echo sx5-nec-superux${UNAME_RELEASE} + exit ;; + SX-6:SUPER-UX:*:*) + echo sx6-nec-superux${UNAME_RELEASE} + exit ;; + Power*:Rhapsody:*:*) + echo powerpc-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Rhapsody:*:*) + echo ${UNAME_MACHINE}-apple-rhapsody${UNAME_RELEASE} + exit ;; + *:Darwin:*:*) + UNAME_PROCESSOR=`uname -p` || UNAME_PROCESSOR=unknown + case $UNAME_PROCESSOR in + unknown) UNAME_PROCESSOR=powerpc ;; + esac + echo ${UNAME_PROCESSOR}-apple-darwin${UNAME_RELEASE} + exit ;; + *:procnto*:*:* | *:QNX:[0123456789]*:*) + UNAME_PROCESSOR=`uname -p` + if test "$UNAME_PROCESSOR" = "x86"; then + UNAME_PROCESSOR=i386 + UNAME_MACHINE=pc + fi + echo ${UNAME_PROCESSOR}-${UNAME_MACHINE}-nto-qnx${UNAME_RELEASE} + exit ;; + *:QNX:*:4*) + echo i386-pc-qnx + exit ;; + NSE-?:NONSTOP_KERNEL:*:*) + echo nse-tandem-nsk${UNAME_RELEASE} + exit ;; + NSR-?:NONSTOP_KERNEL:*:*) + echo nsr-tandem-nsk${UNAME_RELEASE} + exit ;; + *:NonStop-UX:*:*) + echo mips-compaq-nonstopux + exit ;; + BS2000:POSIX*:*:*) + echo bs2000-siemens-sysv + exit ;; + DS/*:UNIX_System_V:*:*) + echo ${UNAME_MACHINE}-${UNAME_SYSTEM}-${UNAME_RELEASE} + exit ;; + *:Plan9:*:*) + # "uname -m" is not consistent, so use $cputype instead. 386 + # is converted to i386 for consistency with other x86 + # operating systems. + if test "$cputype" = "386"; then + UNAME_MACHINE=i386 + else + UNAME_MACHINE="$cputype" + fi + echo ${UNAME_MACHINE}-unknown-plan9 + exit ;; + *:TOPS-10:*:*) + echo pdp10-unknown-tops10 + exit ;; + *:TENEX:*:*) + echo pdp10-unknown-tenex + exit ;; + KS10:TOPS-20:*:* | KL10:TOPS-20:*:* | TYPE4:TOPS-20:*:*) + echo pdp10-dec-tops20 + exit ;; + XKL-1:TOPS-20:*:* | TYPE5:TOPS-20:*:*) + echo pdp10-xkl-tops20 + exit ;; + *:TOPS-20:*:*) + echo pdp10-unknown-tops20 + exit ;; + *:ITS:*:*) + echo pdp10-unknown-its + exit ;; + SEI:*:*:SEIUX) + echo mips-sei-seiux${UNAME_RELEASE} + exit ;; + *:DragonFly:*:*) + echo ${UNAME_MACHINE}-unknown-dragonfly`echo ${UNAME_RELEASE}|sed -e 's/[-(].*//'` + exit ;; + *:*VMS:*:*) + UNAME_MACHINE=`(uname -p) 2>/dev/null` + case "${UNAME_MACHINE}" in + A*) echo alpha-dec-vms ; exit ;; + I*) echo ia64-dec-vms ; exit ;; + V*) echo vax-dec-vms ; exit ;; + esac ;; + *:XENIX:*:SysV) + echo i386-pc-xenix + exit ;; + i*86:skyos:*:*) + echo ${UNAME_MACHINE}-pc-skyos`echo ${UNAME_RELEASE}` | sed -e 's/ .*$//' + exit ;; + i*86:rdos:*:*) + echo ${UNAME_MACHINE}-pc-rdos + exit ;; +esac + +#echo '(No uname command or uname output not recognized.)' 1>&2 +#echo "${UNAME_MACHINE}:${UNAME_SYSTEM}:${UNAME_RELEASE}:${UNAME_VERSION}" 1>&2 + +eval $set_cc_for_build +cat >$dummy.c < +# include +#endif +main () +{ +#if defined (sony) +#if defined (MIPSEB) + /* BFD wants "bsd" instead of "newsos". Perhaps BFD should be changed, + I don't know.... */ + printf ("mips-sony-bsd\n"); exit (0); +#else +#include + printf ("m68k-sony-newsos%s\n", +#ifdef NEWSOS4 + "4" +#else + "" +#endif + ); exit (0); +#endif +#endif + +#if defined (__arm) && defined (__acorn) && defined (__unix) + printf ("arm-acorn-riscix\n"); exit (0); +#endif + +#if defined (hp300) && !defined (hpux) + printf ("m68k-hp-bsd\n"); exit (0); +#endif + +#if defined (NeXT) +#if !defined (__ARCHITECTURE__) +#define __ARCHITECTURE__ "m68k" +#endif + int version; + version=`(hostinfo | sed -n 's/.*NeXT Mach \([0-9]*\).*/\1/p') 2>/dev/null`; + if (version < 4) + printf ("%s-next-nextstep%d\n", __ARCHITECTURE__, version); + else + printf ("%s-next-openstep%d\n", __ARCHITECTURE__, version); + exit (0); +#endif + +#if defined (MULTIMAX) || defined (n16) +#if defined (UMAXV) + printf ("ns32k-encore-sysv\n"); exit (0); +#else +#if defined (CMU) + printf ("ns32k-encore-mach\n"); exit (0); +#else + printf ("ns32k-encore-bsd\n"); exit (0); +#endif +#endif +#endif + +#if defined (__386BSD__) + printf ("i386-pc-bsd\n"); exit (0); +#endif + +#if defined (sequent) +#if defined (i386) + printf ("i386-sequent-dynix\n"); exit (0); +#endif +#if defined (ns32000) + printf ("ns32k-sequent-dynix\n"); exit (0); +#endif +#endif + +#if defined (_SEQUENT_) + struct utsname un; + + uname(&un); + + if (strncmp(un.version, "V2", 2) == 0) { + printf ("i386-sequent-ptx2\n"); exit (0); + } + if (strncmp(un.version, "V1", 2) == 0) { /* XXX is V1 correct? */ + printf ("i386-sequent-ptx1\n"); exit (0); + } + printf ("i386-sequent-ptx\n"); exit (0); + +#endif + +#if defined (vax) +# if !defined (ultrix) +# include +# if defined (BSD) +# if BSD == 43 + printf ("vax-dec-bsd4.3\n"); exit (0); +# else +# if BSD == 199006 + printf ("vax-dec-bsd4.3reno\n"); exit (0); +# else + printf ("vax-dec-bsd\n"); exit (0); +# endif +# endif +# else + printf ("vax-dec-bsd\n"); exit (0); +# endif +# else + printf ("vax-dec-ultrix\n"); exit (0); +# endif +#endif + +#if defined (alliant) && defined (i860) + printf ("i860-alliant-bsd\n"); exit (0); +#endif + + exit (1); +} +EOF + +$CC_FOR_BUILD -o $dummy $dummy.c 2>/dev/null && SYSTEM_NAME=`$dummy` && + { echo "$SYSTEM_NAME"; exit; } + +# Apollos put the system type in the environment. + +test -d /usr/apollo && { echo ${ISP}-apollo-${SYSTYPE}; exit; } + +# Convex versions that predate uname can use getsysinfo(1) + +if [ -x /usr/convex/getsysinfo ] +then + case `getsysinfo -f cpu_type` in + c1*) + echo c1-convex-bsd + exit ;; + c2*) + if getsysinfo -f scalar_acc + then echo c32-convex-bsd + else echo c2-convex-bsd + fi + exit ;; + c34*) + echo c34-convex-bsd + exit ;; + c38*) + echo c38-convex-bsd + exit ;; + c4*) + echo c4-convex-bsd + exit ;; + esac +fi + +cat >&2 < in order to provide the needed +information to handle your system. + +config.guess timestamp = $timestamp + +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null` + +hostinfo = `(hostinfo) 2>/dev/null` +/bin/universe = `(/bin/universe) 2>/dev/null` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null` +/bin/arch = `(/bin/arch) 2>/dev/null` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null` + +UNAME_MACHINE = ${UNAME_MACHINE} +UNAME_RELEASE = ${UNAME_RELEASE} +UNAME_SYSTEM = ${UNAME_SYSTEM} +UNAME_VERSION = ${UNAME_VERSION} +EOF + +exit 1 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/cil/config.h.in b/cil/config.h.in new file mode 100644 index 0000000..57dc9f0 --- /dev/null +++ b/cil/config.h.in @@ -0,0 +1,23 @@ +#undef HAVE_WCHAR_T + +#undef HAVE_STDLIB_H + +#undef HAVE_STRINGS_H + +#undef HAVE_SYS_TIME_H + +#undef HAVE_UNISTD_H + +#undef HAVE_CONST + +#undef HAVE_INLINE + +#undef HAVE_TIME_H + +#undef HAVE_MEMCP + +#undef HAVE_MKDIR + +#undef HAVE_SELECT + +#undef HAVE_SOCKET diff --git a/cil/config.sub b/cil/config.sub new file mode 100755 index 0000000..f0675aa --- /dev/null +++ b/cil/config.sub @@ -0,0 +1,1469 @@ +#! /bin/sh +# Configuration validation subroutine script. +# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, +# 2000, 2001, 2002 Free Software Foundation, Inc. + +timestamp='2002-11-30' + +# This file is (in principle) common to ALL GNU software. +# The presence of a machine in this file suggests that SOME GNU software +# can handle that machine. It does not imply ALL GNU software can. +# +# This file is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with this program; if not, write to the Free Software +# Foundation, Inc., 59 Temple Place - Suite 330, +# Boston, MA 02111-1307, USA. + +# As a special exception to the GNU General Public License, if you +# distribute this file as part of a program that contains a +# configuration script generated by Autoconf, you may include it under +# the same distribution terms that you use for the rest of that program. + +# Please send patches to . Submit a context +# diff and a properly formatted ChangeLog entry. +# +# Configuration subroutine to validate and canonicalize a configuration type. +# Supply the specified configuration type as an argument. +# If it is invalid, we print an error message on stderr and exit with code 1. +# Otherwise, we print the canonical config type on stdout and succeed. + +# This file is supposed to be the same for all GNU packages +# and recognize all the CPU types, system types and aliases +# that are meaningful with *any* GNU software. +# Each package is responsible for reporting which valid configurations +# it does not support. The user should be able to distinguish +# a failure to support a valid configuration from a meaningless +# configuration. + +# The goal of this file is to map all the various variations of a given +# machine specification into a single specification in the form: +# CPU_TYPE-MANUFACTURER-OPERATING_SYSTEM +# or in some cases, the newer four-part form: +# CPU_TYPE-MANUFACTURER-KERNEL-OPERATING_SYSTEM +# It is wrong to echo any other type of specification. + +me=`echo "$0" | sed -e 's,.*/,,'` + +usage="\ +Usage: $0 [OPTION] CPU-MFR-OPSYS + $0 [OPTION] ALIAS + +Canonicalize a configuration name. + +Operation modes: + -h, --help print this help, then exit + -t, --time-stamp print date of last modification, then exit + -v, --version print version number, then exit + +Report bugs and patches to ." + +version="\ +GNU config.sub ($timestamp) + +Copyright (C) 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001 +Free Software Foundation, Inc. + +This is free software; see the source for copying conditions. There is NO +warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." + +help=" +Try \`$me --help' for more information." + +# Parse command line +while test $# -gt 0 ; do + case $1 in + --time-stamp | --time* | -t ) + echo "$timestamp" ; exit 0 ;; + --version | -v ) + echo "$version" ; exit 0 ;; + --help | --h* | -h ) + echo "$usage"; exit 0 ;; + -- ) # Stop option processing + shift; break ;; + - ) # Use stdin as input. + break ;; + -* ) + echo "$me: invalid option $1$help" + exit 1 ;; + + *local*) + # First pass through any local machine types. + echo $1 + exit 0;; + + * ) + break ;; + esac +done + +case $# in + 0) echo "$me: missing argument$help" >&2 + exit 1;; + 1) ;; + *) echo "$me: too many arguments$help" >&2 + exit 1;; +esac + +# Separate what the user gave into CPU-COMPANY and OS or KERNEL-OS (if any). +# Here we must recognize all the valid KERNEL-OS combinations. +maybe_os=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\2/'` +case $maybe_os in + nto-qnx* | linux-gnu* | freebsd*-gnu* | netbsd*-gnu* | storm-chaos* | os2-emx* | rtmk-nova*) + os=-$maybe_os + basic_machine=`echo $1 | sed 's/^\(.*\)-\([^-]*-[^-]*\)$/\1/'` + ;; + *) + basic_machine=`echo $1 | sed 's/-[^-]*$//'` + if [ $basic_machine != $1 ] + then os=`echo $1 | sed 's/.*-/-/'` + else os=; fi + ;; +esac + +### Let's recognize common machines as not being operating systems so +### that things like config.sub decstation-3100 work. We also +### recognize some manufacturers as not being operating systems, so we +### can provide default operating systems below. +case $os in + -sun*os*) + # Prevent following clause from handling this invalid input. + ;; + -dec* | -mips* | -sequent* | -encore* | -pc532* | -sgi* | -sony* | \ + -att* | -7300* | -3300* | -delta* | -motorola* | -sun[234]* | \ + -unicom* | -ibm* | -next | -hp | -isi* | -apollo | -altos* | \ + -convergent* | -ncr* | -news | -32* | -3600* | -3100* | -hitachi* |\ + -c[123]* | -convex* | -sun | -crds | -omron* | -dg | -ultra | -tti* | \ + -harris | -dolphin | -highlevel | -gould | -cbm | -ns | -masscomp | \ + -apple | -axis) + os= + basic_machine=$1 + ;; + -sim | -cisco | -oki | -wec | -winbond) + os= + basic_machine=$1 + ;; + -scout) + ;; + -wrs) + os=-vxworks + basic_machine=$1 + ;; + -chorusos*) + os=-chorusos + basic_machine=$1 + ;; + -chorusrdb) + os=-chorusrdb + basic_machine=$1 + ;; + -hiux*) + os=-hiuxwe2 + ;; + -sco5) + os=-sco3.2v5 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco4) + os=-sco3.2v4 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2.[4-9]*) + os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco3.2v[4-9]*) + # Don't forget version if it is 3.2v4 or newer. + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -sco*) + os=-sco3.2v2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -udk*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -isc) + os=-isc2.2 + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -clix*) + basic_machine=clipper-intergraph + ;; + -isc*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-pc/'` + ;; + -lynx*) + os=-lynxos + ;; + -ptx*) + basic_machine=`echo $1 | sed -e 's/86-.*/86-sequent/'` + ;; + -windowsnt*) + os=`echo $os | sed -e 's/windowsnt/winnt/'` + ;; + -psos*) + os=-psos + ;; + -mint | -mint[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; +esac + +# Decode aliases for certain CPU-COMPANY combinations. +case $basic_machine in + # Recognize the basic CPU types without company name. + # Some are omitted here because they have special meanings below. + 1750a | 580 \ + | a29k \ + | alpha | alphaev[4-8] | alphaev56 | alphaev6[78] | alphapca5[67] \ + | alpha64 | alpha64ev[4-8] | alpha64ev56 | alpha64ev6[78] | alpha64pca5[67] \ + | arc | arm | arm[bl]e | arme[lb] | armv[2345] | armv[345][lb] | avr \ + | clipper \ + | d10v | d30v | dlx | dsp16xx \ + | fr30 | frv \ + | h8300 | h8500 | hppa | hppa1.[01] | hppa2.0 | hppa2.0[nw] | hppa64 \ + | i370 | i860 | i960 | ia64 \ + | ip2k \ + | m32r | m68000 | m68k | m88k | mcore \ + | mips | mipsbe | mipseb | mipsel | mipsle \ + | mips16 \ + | mips64 | mips64el \ + | mips64vr | mips64vrel \ + | mips64orion | mips64orionel \ + | mips64vr4100 | mips64vr4100el \ + | mips64vr4300 | mips64vr4300el \ + | mips64vr5000 | mips64vr5000el \ + | mipsisa32 | mipsisa32el \ + | mipsisa64 | mipsisa64el \ + | mipsisa64sb1 | mipsisa64sb1el \ + | mipsisa64sr71k | mipsisa64sr71kel \ + | mipstx39 | mipstx39el \ + | mn10200 | mn10300 \ + | ns16k | ns32k \ + | openrisc | or32 \ + | pdp10 | pdp11 | pj | pjl \ + | powerpc | powerpc64 | powerpc64le | powerpcle | ppcbe \ + | pyramid \ + | sh | sh[1234] | sh3e | sh[34]eb | shbe | shle | sh[1234]le | sh3ele \ + | sh64 | sh64le \ + | sparc | sparc64 | sparc86x | sparclet | sparclite | sparcv9 | sparcv9b \ + | strongarm \ + | tahoe | thumb | tic80 | tron \ + | v850 | v850e \ + | we32k \ + | x86 | xscale | xstormy16 | xtensa \ + | z8k) + basic_machine=$basic_machine-unknown + ;; + m6811 | m68hc11 | m6812 | m68hc12) + # Motorola 68HC11/12. + basic_machine=$basic_machine-unknown + os=-none + ;; + m88110 | m680[12346]0 | m683?2 | m68360 | m5200 | v70 | w65 | z8k) + ;; + + # We use `pc' rather than `unknown' + # because (1) that's what they normally are, and + # (2) the word "unknown" tends to confuse beginning users. + i*86 | x86_64) + basic_machine=$basic_machine-pc + ;; + # Object if more than one company name word. + *-*-*) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; + # Recognize the basic CPU types with company name. + 580-* \ + | a29k-* \ + | alpha-* | alphaev[4-8]-* | alphaev56-* | alphaev6[78]-* \ + | alpha64-* | alpha64ev[4-8]-* | alpha64ev56-* | alpha64ev6[78]-* \ + | alphapca5[67]-* | alpha64pca5[67]-* | arc-* \ + | arm-* | armbe-* | armle-* | armeb-* | armv*-* \ + | avr-* \ + | bs2000-* \ + | c[123]* | c30-* | [cjt]90-* | c4x-* | c54x-* \ + | clipper-* | cydra-* \ + | d10v-* | d30v-* | dlx-* \ + | elxsi-* \ + | f30[01]-* | f700-* | fr30-* | frv-* | fx80-* \ + | h8300-* | h8500-* \ + | hppa-* | hppa1.[01]-* | hppa2.0-* | hppa2.0[nw]-* | hppa64-* \ + | i*86-* | i860-* | i960-* | ia64-* \ + | ip2k-* \ + | m32r-* \ + | m68000-* | m680[012346]0-* | m68360-* | m683?2-* | m68k-* \ + | m88110-* | m88k-* | mcore-* \ + | mips-* | mipsbe-* | mipseb-* | mipsel-* | mipsle-* \ + | mips16-* \ + | mips64-* | mips64el-* \ + | mips64vr-* | mips64vrel-* \ + | mips64orion-* | mips64orionel-* \ + | mips64vr4100-* | mips64vr4100el-* \ + | mips64vr4300-* | mips64vr4300el-* \ + | mips64vr5000-* | mips64vr5000el-* \ + | mipsisa32-* | mipsisa32el-* \ + | mipsisa64-* | mipsisa64el-* \ + | mipsisa64sb1-* | mipsisa64sb1el-* \ + | mipsisa64sr71k-* | mipsisa64sr71kel-* \ + | mipstx39 | mipstx39el \ + | none-* | np1-* | ns16k-* | ns32k-* \ + | orion-* \ + | pdp10-* | pdp11-* | pj-* | pjl-* | pn-* | power-* \ + | powerpc-* | powerpc64-* | powerpc64le-* | powerpcle-* | ppcbe-* \ + | pyramid-* \ + | romp-* | rs6000-* \ + | sh-* | sh[1234]-* | sh3e-* | sh[34]eb-* | shbe-* \ + | shle-* | sh[1234]le-* | sh3ele-* | sh64-* | sh64le-* \ + | sparc-* | sparc64-* | sparc86x-* | sparclet-* | sparclite-* \ + | sparcv9-* | sparcv9b-* | strongarm-* | sv1-* | sx?-* \ + | tahoe-* | thumb-* | tic30-* | tic4x-* | tic54x-* | tic80-* | tron-* \ + | v850-* | v850e-* | vax-* \ + | we32k-* \ + | x86-* | x86_64-* | xps100-* | xscale-* | xstormy16-* \ + | xtensa-* \ + | ymp-* \ + | z8k-*) + ;; + # Recognize the various machine names and aliases which stand + # for a CPU type and a company and sometimes even an OS. + 386bsd) + basic_machine=i386-unknown + os=-bsd + ;; + 3b1 | 7300 | 7300-att | att-7300 | pc7300 | safari | unixpc) + basic_machine=m68000-att + ;; + 3b*) + basic_machine=we32k-att + ;; + a29khif) + basic_machine=a29k-amd + os=-udi + ;; + adobe68k) + basic_machine=m68010-adobe + os=-scout + ;; + alliant | fx80) + basic_machine=fx80-alliant + ;; + altos | altos3068) + basic_machine=m68k-altos + ;; + am29k) + basic_machine=a29k-none + os=-bsd + ;; + amdahl) + basic_machine=580-amdahl + os=-sysv + ;; + amiga | amiga-*) + basic_machine=m68k-unknown + ;; + amigaos | amigados) + basic_machine=m68k-unknown + os=-amigaos + ;; + amigaunix | amix) + basic_machine=m68k-unknown + os=-sysv4 + ;; + apollo68) + basic_machine=m68k-apollo + os=-sysv + ;; + apollo68bsd) + basic_machine=m68k-apollo + os=-bsd + ;; + aux) + basic_machine=m68k-apple + os=-aux + ;; + balance) + basic_machine=ns32k-sequent + os=-dynix + ;; + c90) + basic_machine=c90-cray + os=-unicos + ;; + convex-c1) + basic_machine=c1-convex + os=-bsd + ;; + convex-c2) + basic_machine=c2-convex + os=-bsd + ;; + convex-c32) + basic_machine=c32-convex + os=-bsd + ;; + convex-c34) + basic_machine=c34-convex + os=-bsd + ;; + convex-c38) + basic_machine=c38-convex + os=-bsd + ;; + cray | j90) + basic_machine=j90-cray + os=-unicos + ;; + crds | unos) + basic_machine=m68k-crds + ;; + cris | cris-* | etrax*) + basic_machine=cris-axis + ;; + da30 | da30-*) + basic_machine=m68k-da30 + ;; + decstation | decstation-3100 | pmax | pmax-* | pmin | dec3100 | decstatn) + basic_machine=mips-dec + ;; + decsystem10* | dec10*) + basic_machine=pdp10-dec + os=-tops10 + ;; + decsystem20* | dec20*) + basic_machine=pdp10-dec + os=-tops20 + ;; + delta | 3300 | motorola-3300 | motorola-delta \ + | 3300-motorola | delta-motorola) + basic_machine=m68k-motorola + ;; + delta88) + basic_machine=m88k-motorola + os=-sysv3 + ;; + dpx20 | dpx20-*) + basic_machine=rs6000-bull + os=-bosx + ;; + dpx2* | dpx2*-bull) + basic_machine=m68k-bull + os=-sysv3 + ;; + ebmon29k) + basic_machine=a29k-amd + os=-ebmon + ;; + elxsi) + basic_machine=elxsi-elxsi + os=-bsd + ;; + encore | umax | mmax) + basic_machine=ns32k-encore + ;; + es1800 | OSE68k | ose68k | ose | OSE) + basic_machine=m68k-ericsson + os=-ose + ;; + fx2800) + basic_machine=i860-alliant + ;; + genix) + basic_machine=ns32k-ns + ;; + gmicro) + basic_machine=tron-gmicro + os=-sysv + ;; + go32) + basic_machine=i386-pc + os=-go32 + ;; + h3050r* | hiux*) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + h8300hms) + basic_machine=h8300-hitachi + os=-hms + ;; + h8300xray) + basic_machine=h8300-hitachi + os=-xray + ;; + h8500hms) + basic_machine=h8500-hitachi + os=-hms + ;; + harris) + basic_machine=m88k-harris + os=-sysv3 + ;; + hp300-*) + basic_machine=m68k-hp + ;; + hp300bsd) + basic_machine=m68k-hp + os=-bsd + ;; + hp300hpux) + basic_machine=m68k-hp + os=-hpux + ;; + hp3k9[0-9][0-9] | hp9[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k2[0-9][0-9] | hp9k31[0-9]) + basic_machine=m68000-hp + ;; + hp9k3[2-9][0-9]) + basic_machine=m68k-hp + ;; + hp9k6[0-9][0-9] | hp6[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hp9k7[0-79][0-9] | hp7[0-79][0-9]) + basic_machine=hppa1.1-hp + ;; + hp9k78[0-9] | hp78[0-9]) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[67]1 | hp8[67]1 | hp9k80[24] | hp80[24] | hp9k8[78]9 | hp8[78]9 | hp9k893 | hp893) + # FIXME: really hppa2.0-hp + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][13679] | hp8[0-9][13679]) + basic_machine=hppa1.1-hp + ;; + hp9k8[0-9][0-9] | hp8[0-9][0-9]) + basic_machine=hppa1.0-hp + ;; + hppa-next) + os=-nextstep3 + ;; + hppaosf) + basic_machine=hppa1.1-hp + os=-osf + ;; + hppro) + basic_machine=hppa1.1-hp + os=-proelf + ;; + i370-ibm* | ibm*) + basic_machine=i370-ibm + ;; +# I'm not sure what "Sysv32" means. Should this be sysv3.2? + i*86v32) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv32 + ;; + i*86v4*) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv4 + ;; + i*86v) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-sysv + ;; + i*86sol2) + basic_machine=`echo $1 | sed -e 's/86.*/86-pc/'` + os=-solaris2 + ;; + i386mach) + basic_machine=i386-mach + os=-mach + ;; + i386-vsta | vsta) + basic_machine=i386-unknown + os=-vsta + ;; + iris | iris4d) + basic_machine=mips-sgi + case $os in + -irix*) + ;; + *) + os=-irix4 + ;; + esac + ;; + isi68 | isi) + basic_machine=m68k-isi + os=-sysv + ;; + m88k-omron*) + basic_machine=m88k-omron + ;; + magnum | m3230) + basic_machine=mips-mips + os=-sysv + ;; + merlin) + basic_machine=ns32k-utek + os=-sysv + ;; + mingw32) + basic_machine=i386-pc + os=-mingw32 + ;; + miniframe) + basic_machine=m68000-convergent + ;; + *mint | -mint[0-9]* | *MiNT | *MiNT[0-9]*) + basic_machine=m68k-atari + os=-mint + ;; + mips3*-*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'` + ;; + mips3*) + basic_machine=`echo $basic_machine | sed -e 's/mips3/mips64/'`-unknown + ;; + mmix*) + basic_machine=mmix-knuth + os=-mmixware + ;; + monitor) + basic_machine=m68k-rom68k + os=-coff + ;; + morphos) + basic_machine=powerpc-unknown + os=-morphos + ;; + msdos) + basic_machine=i386-pc + os=-msdos + ;; + mvs) + basic_machine=i370-ibm + os=-mvs + ;; + ncr3000) + basic_machine=i486-ncr + os=-sysv4 + ;; + netbsd386) + basic_machine=i386-unknown + os=-netbsd + ;; + netwinder) + basic_machine=armv4l-rebel + os=-linux + ;; + news | news700 | news800 | news900) + basic_machine=m68k-sony + os=-newsos + ;; + news1000) + basic_machine=m68030-sony + os=-newsos + ;; + news-3600 | risc-news) + basic_machine=mips-sony + os=-newsos + ;; + necv70) + basic_machine=v70-nec + os=-sysv + ;; + next | m*-next ) + basic_machine=m68k-next + case $os in + -nextstep* ) + ;; + -ns2*) + os=-nextstep2 + ;; + *) + os=-nextstep3 + ;; + esac + ;; + nh3000) + basic_machine=m68k-harris + os=-cxux + ;; + nh[45]000) + basic_machine=m88k-harris + os=-cxux + ;; + nindy960) + basic_machine=i960-intel + os=-nindy + ;; + mon960) + basic_machine=i960-intel + os=-mon960 + ;; + nonstopux) + basic_machine=mips-compaq + os=-nonstopux + ;; + np1) + basic_machine=np1-gould + ;; + nsr-tandem) + basic_machine=nsr-tandem + ;; + op50n-* | op60c-*) + basic_machine=hppa1.1-oki + os=-proelf + ;; + or32 | or32-*) + basic_machine=or32-unknown + os=-coff + ;; + OSE68000 | ose68000) + basic_machine=m68000-ericsson + os=-ose + ;; + os68k) + basic_machine=m68k-none + os=-os68k + ;; + pa-hitachi) + basic_machine=hppa1.1-hitachi + os=-hiuxwe2 + ;; + paragon) + basic_machine=i860-intel + os=-osf + ;; + pbd) + basic_machine=sparc-tti + ;; + pbb) + basic_machine=m68k-tti + ;; + pc532 | pc532-*) + basic_machine=ns32k-pc532 + ;; + pentium | p5 | k5 | k6 | nexgen | viac3) + basic_machine=i586-pc + ;; + pentiumpro | p6 | 6x86 | athlon | athlon_*) + basic_machine=i686-pc + ;; + pentiumii | pentium2) + basic_machine=i686-pc + ;; + pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) + basic_machine=i586-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumpro-* | p6-* | 6x86-* | athlon-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pentiumii-* | pentium2-*) + basic_machine=i686-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + pn) + basic_machine=pn-gould + ;; + power) basic_machine=power-ibm + ;; + ppc) basic_machine=powerpc-unknown + ;; + ppc-*) basic_machine=powerpc-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppcle | powerpclittle | ppc-le | powerpc-little) + basic_machine=powerpcle-unknown + ;; + ppcle-* | powerpclittle-*) + basic_machine=powerpcle-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64) basic_machine=powerpc64-unknown + ;; + ppc64-*) basic_machine=powerpc64-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ppc64le | powerpc64little | ppc64-le | powerpc64-little) + basic_machine=powerpc64le-unknown + ;; + ppc64le-* | powerpc64little-*) + basic_machine=powerpc64le-`echo $basic_machine | sed 's/^[^-]*-//'` + ;; + ps2) + basic_machine=i386-ibm + ;; + pw32) + basic_machine=i586-unknown + os=-pw32 + ;; + rom68k) + basic_machine=m68k-rom68k + os=-coff + ;; + rm[46]00) + basic_machine=mips-siemens + ;; + rtpc | rtpc-*) + basic_machine=romp-ibm + ;; + s390 | s390-*) + basic_machine=s390-ibm + ;; + s390x | s390x-*) + basic_machine=s390x-ibm + ;; + sa29200) + basic_machine=a29k-amd + os=-udi + ;; + sb1) + basic_machine=mipsisa64sb1-unknown + ;; + sb1el) + basic_machine=mipsisa64sb1el-unknown + ;; + sequent) + basic_machine=i386-sequent + ;; + sh) + basic_machine=sh-hitachi + os=-hms + ;; + sparclite-wrs | simso-wrs) + basic_machine=sparclite-wrs + os=-vxworks + ;; + sps7) + basic_machine=m68k-bull + os=-sysv2 + ;; + spur) + basic_machine=spur-unknown + ;; + st2000) + basic_machine=m68k-tandem + ;; + stratus) + basic_machine=i860-stratus + os=-sysv4 + ;; + sun2) + basic_machine=m68000-sun + ;; + sun2os3) + basic_machine=m68000-sun + os=-sunos3 + ;; + sun2os4) + basic_machine=m68000-sun + os=-sunos4 + ;; + sun3os3) + basic_machine=m68k-sun + os=-sunos3 + ;; + sun3os4) + basic_machine=m68k-sun + os=-sunos4 + ;; + sun4os3) + basic_machine=sparc-sun + os=-sunos3 + ;; + sun4os4) + basic_machine=sparc-sun + os=-sunos4 + ;; + sun4sol2) + basic_machine=sparc-sun + os=-solaris2 + ;; + sun3 | sun3-*) + basic_machine=m68k-sun + ;; + sun4) + basic_machine=sparc-sun + ;; + sun386 | sun386i | roadrunner) + basic_machine=i386-sun + ;; + sv1) + basic_machine=sv1-cray + os=-unicos + ;; + symmetry) + basic_machine=i386-sequent + os=-dynix + ;; + t3d) + basic_machine=alpha-cray + os=-unicos + ;; + t3e) + basic_machine=alphaev5-cray + os=-unicos + ;; + t90) + basic_machine=t90-cray + os=-unicos + ;; + tic4x | c4x*) + basic_machine=tic4x-unknown + os=-coff + ;; + tic54x | c54x*) + basic_machine=tic54x-unknown + os=-coff + ;; + tx39) + basic_machine=mipstx39-unknown + ;; + tx39el) + basic_machine=mipstx39el-unknown + ;; + toad1) + basic_machine=pdp10-xkl + os=-tops20 + ;; + tower | tower-32) + basic_machine=m68k-ncr + ;; + udi29k) + basic_machine=a29k-amd + os=-udi + ;; + ultra3) + basic_machine=a29k-nyu + os=-sym1 + ;; + v810 | necv810) + basic_machine=v810-nec + os=-none + ;; + vaxv) + basic_machine=vax-dec + os=-sysv + ;; + vms) + basic_machine=vax-dec + os=-vms + ;; + vpp*|vx|vx-*) + basic_machine=f301-fujitsu + ;; + vxworks960) + basic_machine=i960-wrs + os=-vxworks + ;; + vxworks68) + basic_machine=m68k-wrs + os=-vxworks + ;; + vxworks29k) + basic_machine=a29k-wrs + os=-vxworks + ;; + w65*) + basic_machine=w65-wdc + os=-none + ;; + w89k-*) + basic_machine=hppa1.1-winbond + os=-proelf + ;; + xps | xps100) + basic_machine=xps100-honeywell + ;; + ymp) + basic_machine=ymp-cray + os=-unicos + ;; + z8k-*-coff) + basic_machine=z8k-unknown + os=-sim + ;; + none) + basic_machine=none-none + os=-none + ;; + +# Here we handle the default manufacturer of certain CPU types. It is in +# some cases the only manufacturer, in others, it is the most popular. + w89k) + basic_machine=hppa1.1-winbond + ;; + op50n) + basic_machine=hppa1.1-oki + ;; + op60c) + basic_machine=hppa1.1-oki + ;; + romp) + basic_machine=romp-ibm + ;; + rs6000) + basic_machine=rs6000-ibm + ;; + vax) + basic_machine=vax-dec + ;; + pdp10) + # there are many clones, so DEC is not a safe bet + basic_machine=pdp10-unknown + ;; + pdp11) + basic_machine=pdp11-dec + ;; + we32k) + basic_machine=we32k-att + ;; + sh3 | sh4 | sh3eb | sh4eb | sh[1234]le | sh3ele) + basic_machine=sh-unknown + ;; + sh64) + basic_machine=sh64-unknown + ;; + sparc | sparcv9 | sparcv9b) + basic_machine=sparc-sun + ;; + cydra) + basic_machine=cydra-cydrome + ;; + orion) + basic_machine=orion-highlevel + ;; + orion105) + basic_machine=clipper-highlevel + ;; + mac | mpw | mac-mpw) + basic_machine=m68k-apple + ;; + pmac | pmac-mpw) + basic_machine=powerpc-apple + ;; + *-unknown) + # Make sure to match an already-canonicalized machine name. + ;; + *) + echo Invalid configuration \`$1\': machine \`$basic_machine\' not recognized 1>&2 + exit 1 + ;; +esac + +# Here we canonicalize certain aliases for manufacturers. +case $basic_machine in + *-digital*) + basic_machine=`echo $basic_machine | sed 's/digital.*/dec/'` + ;; + *-commodore*) + basic_machine=`echo $basic_machine | sed 's/commodore.*/cbm/'` + ;; + *) + ;; +esac + +# Decode manufacturer-specific aliases for certain operating systems. + +if [ x"$os" != x"" ] +then +case $os in + # First match some system type aliases + # that might get confused with valid system types. + # -solaris* is a basic system type, with this one exception. + -solaris1 | -solaris1.*) + os=`echo $os | sed -e 's|solaris1|sunos4|'` + ;; + -solaris) + os=-solaris2 + ;; + -svr4*) + os=-sysv4 + ;; + -unixware*) + os=-sysv4.2uw + ;; + -gnu/linux*) + os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` + ;; + # First accept the basic system types. + # The portable systems comes first. + # Each alternative MUST END IN A *, to match a version number. + # -sysv* is not here because it comes later, after sysvr4. + -gnu* | -bsd* | -mach* | -minix* | -genix* | -ultrix* | -irix* \ + | -*vms* | -sco* | -esix* | -isc* | -aix* | -sunos | -sunos[34]*\ + | -hpux* | -unos* | -osf* | -luna* | -dgux* | -solaris* | -sym* \ + | -amigaos* | -amigados* | -msdos* | -newsos* | -unicos* | -aof* \ + | -aos* \ + | -nindy* | -vxsim* | -vxworks* | -ebmon* | -hms* | -mvs* \ + | -clix* | -riscos* | -uniplus* | -iris* | -rtu* | -xenix* \ + | -hiux* | -386bsd* | -netbsd* | -openbsd* | -freebsd* | -riscix* \ + | -lynxos* | -bosx* | -nextstep* | -cxux* | -aout* | -elf* | -oabi* \ + | -ptx* | -coff* | -ecoff* | -winnt* | -domain* | -vsta* \ + | -udi* | -eabi* | -lites* | -ieee* | -go32* | -aux* \ + | -chorusos* | -chorusrdb* \ + | -cygwin* | -pe* | -psos* | -moss* | -proelf* | -rtems* \ + | -mingw32* | -linux-gnu* | -uxpv* | -beos* | -mpeix* | -udk* \ + | -interix* | -uwin* | -mks* | -rhapsody* | -darwin* | -opened* \ + | -openstep* | -oskit* | -conix* | -pw32* | -nonstopux* \ + | -storm-chaos* | -tops10* | -tenex* | -tops20* | -its* \ + | -os2* | -vos* | -palmos* | -uclinux* | -nucleus* \ + | -morphos* | -superux* | -rtmk* | -rtmk-nova* | -windiss* \ + | -powermax* | -dnix*) + # Remember, each alternative MUST END IN *, to match a version number. + ;; + -qnx*) + case $basic_machine in + x86-* | i*86-*) + ;; + *) + os=-nto$os + ;; + esac + ;; + -nto-qnx*) + ;; + -nto*) + os=`echo $os | sed -e 's|nto|nto-qnx|'` + ;; + -sim | -es1800* | -hms* | -xray | -os68k* | -none* | -v88r* \ + | -windows* | -osx | -abug | -netware* | -os9* | -beos* \ + | -macos* | -mpw* | -magic* | -mmixware* | -mon960* | -lnews*) + ;; + -mac*) + os=`echo $os | sed -e 's|mac|macos|'` + ;; + -linux*) + os=`echo $os | sed -e 's|linux|linux-gnu|'` + ;; + -sunos5*) + os=`echo $os | sed -e 's|sunos5|solaris2|'` + ;; + -sunos6*) + os=`echo $os | sed -e 's|sunos6|solaris3|'` + ;; + -opened*) + os=-openedition + ;; + -wince*) + os=-wince + ;; + -osfrose*) + os=-osfrose + ;; + -osf*) + os=-osf + ;; + -utek*) + os=-bsd + ;; + -dynix*) + os=-bsd + ;; + -acis*) + os=-aos + ;; + -atheos*) + os=-atheos + ;; + -386bsd) + os=-bsd + ;; + -ctix* | -uts*) + os=-sysv + ;; + -nova*) + os=-rtmk-nova + ;; + -ns2 ) + os=-nextstep2 + ;; + -nsk*) + os=-nsk + ;; + # Preserve the version number of sinix5. + -sinix5.*) + os=`echo $os | sed -e 's|sinix|sysv|'` + ;; + -sinix*) + os=-sysv4 + ;; + -triton*) + os=-sysv3 + ;; + -oss*) + os=-sysv3 + ;; + -svr4) + os=-sysv4 + ;; + -svr3) + os=-sysv3 + ;; + -sysvr4) + os=-sysv4 + ;; + # This must come after -sysvr4. + -sysv*) + ;; + -ose*) + os=-ose + ;; + -es1800*) + os=-ose + ;; + -xenix) + os=-xenix + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + os=-mint + ;; + -none) + ;; + *) + # Get rid of the `-' at the beginning of $os. + os=`echo $os | sed 's/[^-]*-//'` + echo Invalid configuration \`$1\': system \`$os\' not recognized 1>&2 + exit 1 + ;; +esac +else + +# Here we handle the default operating systems that come with various machines. +# The value should be what the vendor currently ships out the door with their +# machine or put another way, the most popular os provided with the machine. + +# Note that if you're going to try to match "-MANUFACTURER" here (say, +# "-sun"), then you have to tell the case statement up towards the top +# that MANUFACTURER isn't an operating system. Otherwise, code above +# will signal an error saying that MANUFACTURER isn't an operating +# system, and we'll never get to this point. + +case $basic_machine in + *-acorn) + os=-riscix1.2 + ;; + arm*-rebel) + os=-linux + ;; + arm*-semi) + os=-aout + ;; + # This must come before the *-dec entry. + pdp10-*) + os=-tops20 + ;; + pdp11-*) + os=-none + ;; + *-dec | vax-*) + os=-ultrix4.2 + ;; + m68*-apollo) + os=-domain + ;; + i386-sun) + os=-sunos4.0.2 + ;; + m68000-sun) + os=-sunos3 + # This also exists in the configure program, but was not the + # default. + # os=-sunos4 + ;; + m68*-cisco) + os=-aout + ;; + mips*-cisco) + os=-elf + ;; + mips*-*) + os=-elf + ;; + or32-*) + os=-coff + ;; + *-tti) # must be before sparc entry or we get the wrong os. + os=-sysv3 + ;; + sparc-* | *-sun) + os=-sunos4.1.1 + ;; + *-be) + os=-beos + ;; + *-ibm) + os=-aix + ;; + *-wec) + os=-proelf + ;; + *-winbond) + os=-proelf + ;; + *-oki) + os=-proelf + ;; + *-hp) + os=-hpux + ;; + *-hitachi) + os=-hiux + ;; + i860-* | *-att | *-ncr | *-altos | *-motorola | *-convergent) + os=-sysv + ;; + *-cbm) + os=-amigaos + ;; + *-dg) + os=-dgux + ;; + *-dolphin) + os=-sysv3 + ;; + m68k-ccur) + os=-rtu + ;; + m88k-omron*) + os=-luna + ;; + *-next ) + os=-nextstep + ;; + *-sequent) + os=-ptx + ;; + *-crds) + os=-unos + ;; + *-ns) + os=-genix + ;; + i370-*) + os=-mvs + ;; + *-next) + os=-nextstep3 + ;; + *-gould) + os=-sysv + ;; + *-highlevel) + os=-bsd + ;; + *-encore) + os=-bsd + ;; + *-sgi) + os=-irix + ;; + *-siemens) + os=-sysv4 + ;; + *-masscomp) + os=-rtu + ;; + f30[01]-fujitsu | f700-fujitsu) + os=-uxpv + ;; + *-rom68k) + os=-coff + ;; + *-*bug) + os=-coff + ;; + *-apple) + os=-macos + ;; + *-atari*) + os=-mint + ;; + *) + os=-none + ;; +esac +fi + +# Here we handle the case where we know the os, and the CPU type, but not the +# manufacturer. We pick the logical manufacturer. +vendor=unknown +case $basic_machine in + *-unknown) + case $os in + -riscix*) + vendor=acorn + ;; + -sunos*) + vendor=sun + ;; + -aix*) + vendor=ibm + ;; + -beos*) + vendor=be + ;; + -hpux*) + vendor=hp + ;; + -mpeix*) + vendor=hp + ;; + -hiux*) + vendor=hitachi + ;; + -unos*) + vendor=crds + ;; + -dgux*) + vendor=dg + ;; + -luna*) + vendor=omron + ;; + -genix*) + vendor=ns + ;; + -mvs* | -opened*) + vendor=ibm + ;; + -ptx*) + vendor=sequent + ;; + -vxsim* | -vxworks* | -windiss*) + vendor=wrs + ;; + -aux*) + vendor=apple + ;; + -hms*) + vendor=hitachi + ;; + -mpw* | -macos*) + vendor=apple + ;; + -*mint | -mint[0-9]* | -*MiNT | -MiNT[0-9]*) + vendor=atari + ;; + -vos*) + vendor=stratus + ;; + esac + basic_machine=`echo $basic_machine | sed "s/unknown/$vendor/"` + ;; +esac + +echo $basic_machine$os +exit 0 + +# Local variables: +# eval: (add-hook 'write-file-hooks 'time-stamp) +# time-stamp-start: "timestamp='" +# time-stamp-format: "%:y-%02m-%02d" +# time-stamp-end: "'" +# End: diff --git a/cil/configure b/cil/configure new file mode 100755 index 0000000..fe8634b --- /dev/null +++ b/cil/configure @@ -0,0 +1,5697 @@ +#! /bin/sh +# Guess values for system-dependent variables and create Makefiles. +# Generated by GNU Autoconf 2.59. +# +# Copyright (C) 2003 Free Software Foundation, Inc. +# This configure script is free software; the Free Software Foundation +# gives unlimited permission to copy, distribute and modify it. +## --------------------- ## +## M4sh Initialization. ## +## --------------------- ## + +# Be Bourne compatible +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then + emulate sh + NULLCMD=: + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' +elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then + set -o posix +fi +DUALCASE=1; export DUALCASE # for MKS sh + +# Support unset when possible. +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + as_unset=unset +else + as_unset=false +fi + + +# Work around bugs in pre-3.0 UWIN ksh. +$as_unset ENV MAIL MAILPATH +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +for as_var in \ + LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ + LC_TELEPHONE LC_TIME +do + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then + eval $as_var=C; export $as_var + else + $as_unset $as_var + fi +done + +# Required to use basename. +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi + +if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + + +# Name of the executable. +as_me=`$as_basename "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)$' \| \ + . : '\(.\)' 2>/dev/null || +echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } + /^X\/\(\/\/\)$/{ s//\1/; q; } + /^X\/\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + + +# PATH needs CR, and LINENO needs CR and PATH. +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + echo "#! /bin/sh" >conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi + + + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" || { + # Find who we are. Look in the path if we contain no path at all + # relative or not. + case $0 in + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break +done + + ;; + esac + # We did not find ourselves, most probably we were run as `sh COMMAND' + # in which case we are not to be found in the path. + if test "x$as_myself" = x; then + as_myself=$0 + fi + if test ! -f "$as_myself"; then + { echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2 + { (exit 1); exit 1; }; } + fi + case $CONFIG_SHELL in + '') + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for as_base in sh bash ksh sh5; do + case $as_dir in + /*) + if ("$as_dir/$as_base" -c ' + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then + $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } + $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } + CONFIG_SHELL=$as_dir/$as_base + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$0" ${1+"$@"} + fi;; + esac + done +done +;; + esac + + # Create $as_me.lineno as a copy of $as_myself, but with $LINENO + # uniformly replaced by the line number. The first 'sed' inserts a + # line-number line before each line; the second 'sed' does the real + # work. The second script uses 'N' to pair each line-number line + # with the numbered line, and appends trailing '-' during + # substitution so that $LINENO is not a special case at line end. + # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the + # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) + sed '=' <$as_myself | + sed ' + N + s,$,-, + : loop + s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, + t loop + s,-$,, + s,^['$as_cr_digits']*\n,, + ' >$as_me.lineno && + chmod +x $as_me.lineno || + { echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2 + { (exit 1); exit 1; }; } + + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensible to this). + . ./$as_me.lineno + # Exit status is that of the last command. + exit +} + + +case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in + *c*,-n*) ECHO_N= ECHO_C=' +' ECHO_T=' ' ;; + *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; + *) ECHO_N= ECHO_C='\c' ECHO_T= ;; +esac + +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi + +rm -f conf$$ conf$$.exe conf$$.file +echo >conf$$.file +if ln -s conf$$.file conf$$ 2>/dev/null; then + # We could just check for DJGPP; but this test a) works b) is more generic + # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). + if test -f conf$$.exe; then + # Don't use ln at all; we don't have any links + as_ln_s='cp -p' + else + as_ln_s='ln -s' + fi +elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.file + +if mkdir -p . 2>/dev/null; then + as_mkdir_p=: +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_executable_p="test -f" + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +# IFS +# We need space, tab and new line, in precisely that order. +as_nl=' +' +IFS=" $as_nl" + +# CDPATH. +$as_unset CDPATH + + +# Name of the host. +# hostname on some systems (SVR3.2, Linux) returns a bogus exit status, +# so uname gets run too. +ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +exec 6>&1 + +# +# Initializations. +# +ac_default_prefix=/usr/local +ac_config_libobj_dir=. +cross_compiling=no +subdirs= +MFLAGS= +MAKEFLAGS= +SHELL=${CONFIG_SHELL-/bin/sh} + +# Maximum number of lines to put in a shell here document. +# This variable seems obsolete. It should probably be removed, and +# only ac_max_sed_lines should be used. +: ${ac_max_here_lines=38} + +# Identity of this package. +PACKAGE_NAME= +PACKAGE_TARNAME= +PACKAGE_VERSION= +PACKAGE_STRING= +PACKAGE_BUGREPORT= + +ac_unique_file="src/cil.mli" +# Factoring default headers for most tests. +ac_includes_default="\ +#include +#if HAVE_SYS_TYPES_H +# include +#endif +#if HAVE_SYS_STAT_H +# include +#endif +#if STDC_HEADERS +# include +# include +#else +# if HAVE_STDLIB_H +# include +# endif +#endif +#if HAVE_STRING_H +# if !STDC_HEADERS && HAVE_MEMORY_H +# include +# endif +# include +#endif +#if HAVE_STRINGS_H +# include +#endif +#if HAVE_INTTYPES_H +# include +#else +# if HAVE_STDINT_H +# include +# endif +#endif +#if HAVE_UNISTD_H +# include +#endif" + +ac_subst_vars='CIL_FEATURES_DEFINES NEWLINE SHELL PATH_SEPARATOR PACKAGE_NAME PACKAGE_TARNAME PACKAGE_VERSION PACKAGE_STRING PACKAGE_BUGREPORT exec_prefix prefix program_transform_name bindir sbindir libexecdir datadir sysconfdir sharedstatedir localstatedir libdir includedir oldincludedir infodir mandir build_alias host_alias target_alias DEFS ECHO_C ECHO_N ECHO_T LIBS CC CFLAGS LDFLAGS CPPFLAGS ac_ct_CC EXEEXT OBJEXT INSTALL_PROGRAM INSTALL_SCRIPT INSTALL_DATA build build_cpu build_vendor build_os host host_cpu host_vendor host_os target target_cpu target_vendor target_os CPP EGREP LIBOBJS ARCHOS CILHOME HAS_MSVC DEFAULT_COMPILER DEFAULT_CIL_MODE CIL_VERSION_MAJOR CIL_VERSION_MINOR CIL_VERSION_REV CIL_VERSION CYCLES_PER_USEC HAS_PERFCOUNT HAVE_BUILTIN_VA_LIST THREAD_IS_KEYWORD UNDERSCORE_NAME EXTRAFEATURES EXTRASRCDIRS LTLIBOBJS' +ac_subst_files='' + +# Initialize some variables set by options. +ac_init_help= +ac_init_version=false +# The variables have the same names as the options, with +# dashes changed to underlines. +cache_file=/dev/null +exec_prefix=NONE +no_create= +no_recursion= +prefix=NONE +program_prefix=NONE +program_suffix=NONE +program_transform_name=s,x,x, +silent= +site= +srcdir= +verbose= +x_includes=NONE +x_libraries=NONE + +# Installation directory options. +# These are left unexpanded so users can "make install exec_prefix=/foo" +# and all the variables that are supposed to be based on exec_prefix +# by default will actually change. +# Use braces instead of parens because sh, perl, etc. also accept them. +bindir='${exec_prefix}/bin' +sbindir='${exec_prefix}/sbin' +libexecdir='${exec_prefix}/libexec' +datadir='${prefix}/share' +sysconfdir='${prefix}/etc' +sharedstatedir='${prefix}/com' +localstatedir='${prefix}/var' +libdir='${exec_prefix}/lib' +includedir='${prefix}/include' +oldincludedir='/usr/include' +infodir='${prefix}/info' +mandir='${prefix}/man' + +ac_prev= +for ac_option +do + # If the previous option needs an argument, assign it. + if test -n "$ac_prev"; then + eval "$ac_prev=\$ac_option" + ac_prev= + continue + fi + + ac_optarg=`expr "x$ac_option" : 'x[^=]*=\(.*\)'` + + # Accept the important Cygnus configure options, so we can diagnose typos. + + case $ac_option in + + -bindir | --bindir | --bindi | --bind | --bin | --bi) + ac_prev=bindir ;; + -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*) + bindir=$ac_optarg ;; + + -build | --build | --buil | --bui | --bu) + ac_prev=build_alias ;; + -build=* | --build=* | --buil=* | --bui=* | --bu=*) + build_alias=$ac_optarg ;; + + -cache-file | --cache-file | --cache-fil | --cache-fi \ + | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c) + ac_prev=cache_file ;; + -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \ + | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*) + cache_file=$ac_optarg ;; + + --config-cache | -C) + cache_file=config.cache ;; + + -datadir | --datadir | --datadi | --datad | --data | --dat | --da) + ac_prev=datadir ;; + -datadir=* | --datadir=* | --datadi=* | --datad=* | --data=* | --dat=* \ + | --da=*) + datadir=$ac_optarg ;; + + -disable-* | --disable-*) + ac_feature=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid feature name: $ac_feature" >&2 + { (exit 1); exit 1; }; } + ac_feature=`echo $ac_feature | sed 's/-/_/g'` + eval "enable_$ac_feature=no" ;; + + -enable-* | --enable-*) + ac_feature=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_feature" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid feature name: $ac_feature" >&2 + { (exit 1); exit 1; }; } + ac_feature=`echo $ac_feature | sed 's/-/_/g'` + case $ac_option in + *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; + *) ac_optarg=yes ;; + esac + eval "enable_$ac_feature='$ac_optarg'" ;; + + -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \ + | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \ + | --exec | --exe | --ex) + ac_prev=exec_prefix ;; + -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \ + | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \ + | --exec=* | --exe=* | --ex=*) + exec_prefix=$ac_optarg ;; + + -gas | --gas | --ga | --g) + # Obsolete; use --with-gas. + with_gas=yes ;; + + -help | --help | --hel | --he | -h) + ac_init_help=long ;; + -help=r* | --help=r* | --hel=r* | --he=r* | -hr*) + ac_init_help=recursive ;; + -help=s* | --help=s* | --hel=s* | --he=s* | -hs*) + ac_init_help=short ;; + + -host | --host | --hos | --ho) + ac_prev=host_alias ;; + -host=* | --host=* | --hos=* | --ho=*) + host_alias=$ac_optarg ;; + + -includedir | --includedir | --includedi | --included | --include \ + | --includ | --inclu | --incl | --inc) + ac_prev=includedir ;; + -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \ + | --includ=* | --inclu=* | --incl=* | --inc=*) + includedir=$ac_optarg ;; + + -infodir | --infodir | --infodi | --infod | --info | --inf) + ac_prev=infodir ;; + -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*) + infodir=$ac_optarg ;; + + -libdir | --libdir | --libdi | --libd) + ac_prev=libdir ;; + -libdir=* | --libdir=* | --libdi=* | --libd=*) + libdir=$ac_optarg ;; + + -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \ + | --libexe | --libex | --libe) + ac_prev=libexecdir ;; + -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \ + | --libexe=* | --libex=* | --libe=*) + libexecdir=$ac_optarg ;; + + -localstatedir | --localstatedir | --localstatedi | --localstated \ + | --localstate | --localstat | --localsta | --localst \ + | --locals | --local | --loca | --loc | --lo) + ac_prev=localstatedir ;; + -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \ + | --localstate=* | --localstat=* | --localsta=* | --localst=* \ + | --locals=* | --local=* | --loca=* | --loc=* | --lo=*) + localstatedir=$ac_optarg ;; + + -mandir | --mandir | --mandi | --mand | --man | --ma | --m) + ac_prev=mandir ;; + -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*) + mandir=$ac_optarg ;; + + -nfp | --nfp | --nf) + # Obsolete; use --without-fp. + with_fp=no ;; + + -no-create | --no-create | --no-creat | --no-crea | --no-cre \ + | --no-cr | --no-c | -n) + no_create=yes ;; + + -no-recursion | --no-recursion | --no-recursio | --no-recursi \ + | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r) + no_recursion=yes ;; + + -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \ + | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \ + | --oldin | --oldi | --old | --ol | --o) + ac_prev=oldincludedir ;; + -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \ + | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \ + | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*) + oldincludedir=$ac_optarg ;; + + -prefix | --prefix | --prefi | --pref | --pre | --pr | --p) + ac_prev=prefix ;; + -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*) + prefix=$ac_optarg ;; + + -program-prefix | --program-prefix | --program-prefi | --program-pref \ + | --program-pre | --program-pr | --program-p) + ac_prev=program_prefix ;; + -program-prefix=* | --program-prefix=* | --program-prefi=* \ + | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*) + program_prefix=$ac_optarg ;; + + -program-suffix | --program-suffix | --program-suffi | --program-suff \ + | --program-suf | --program-su | --program-s) + ac_prev=program_suffix ;; + -program-suffix=* | --program-suffix=* | --program-suffi=* \ + | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*) + program_suffix=$ac_optarg ;; + + -program-transform-name | --program-transform-name \ + | --program-transform-nam | --program-transform-na \ + | --program-transform-n | --program-transform- \ + | --program-transform | --program-transfor \ + | --program-transfo | --program-transf \ + | --program-trans | --program-tran \ + | --progr-tra | --program-tr | --program-t) + ac_prev=program_transform_name ;; + -program-transform-name=* | --program-transform-name=* \ + | --program-transform-nam=* | --program-transform-na=* \ + | --program-transform-n=* | --program-transform-=* \ + | --program-transform=* | --program-transfor=* \ + | --program-transfo=* | --program-transf=* \ + | --program-trans=* | --program-tran=* \ + | --progr-tra=* | --program-tr=* | --program-t=*) + program_transform_name=$ac_optarg ;; + + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + silent=yes ;; + + -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb) + ac_prev=sbindir ;; + -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \ + | --sbi=* | --sb=*) + sbindir=$ac_optarg ;; + + -sharedstatedir | --sharedstatedir | --sharedstatedi \ + | --sharedstated | --sharedstate | --sharedstat | --sharedsta \ + | --sharedst | --shareds | --shared | --share | --shar \ + | --sha | --sh) + ac_prev=sharedstatedir ;; + -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \ + | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \ + | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \ + | --sha=* | --sh=*) + sharedstatedir=$ac_optarg ;; + + -site | --site | --sit) + ac_prev=site ;; + -site=* | --site=* | --sit=*) + site=$ac_optarg ;; + + -srcdir | --srcdir | --srcdi | --srcd | --src | --sr) + ac_prev=srcdir ;; + -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*) + srcdir=$ac_optarg ;; + + -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \ + | --syscon | --sysco | --sysc | --sys | --sy) + ac_prev=sysconfdir ;; + -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \ + | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*) + sysconfdir=$ac_optarg ;; + + -target | --target | --targe | --targ | --tar | --ta | --t) + ac_prev=target_alias ;; + -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*) + target_alias=$ac_optarg ;; + + -v | -verbose | --verbose | --verbos | --verbo | --verb) + verbose=yes ;; + + -version | --version | --versio | --versi | --vers | -V) + ac_init_version=: ;; + + -with-* | --with-*) + ac_package=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid package name: $ac_package" >&2 + { (exit 1); exit 1; }; } + ac_package=`echo $ac_package| sed 's/-/_/g'` + case $ac_option in + *=*) ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"`;; + *) ac_optarg=yes ;; + esac + eval "with_$ac_package='$ac_optarg'" ;; + + -without-* | --without-*) + ac_package=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_package" : ".*[^-_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid package name: $ac_package" >&2 + { (exit 1); exit 1; }; } + ac_package=`echo $ac_package | sed 's/-/_/g'` + eval "with_$ac_package=no" ;; + + --x) + # Obsolete; use --with-x. + with_x=yes ;; + + -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \ + | --x-incl | --x-inc | --x-in | --x-i) + ac_prev=x_includes ;; + -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \ + | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*) + x_includes=$ac_optarg ;; + + -x-libraries | --x-libraries | --x-librarie | --x-librari \ + | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l) + ac_prev=x_libraries ;; + -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \ + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + + -*) { echo "$as_me: error: unrecognized option: $ac_option +Try \`$0 --help' for more information." >&2 + { (exit 1); exit 1; }; } + ;; + + *=*) + ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='` + # Reject names that are not valid shell variable names. + expr "x$ac_envvar" : ".*[^_$as_cr_alnum]" >/dev/null && + { echo "$as_me: error: invalid variable name: $ac_envvar" >&2 + { (exit 1); exit 1; }; } + ac_optarg=`echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` + eval "$ac_envvar='$ac_optarg'" + export $ac_envvar ;; + + *) + # FIXME: should be removed in autoconf 3.0. + echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + echo "$as_me: WARNING: invalid host type: $ac_option" >&2 + : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} + ;; + + esac +done + +if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` + { echo "$as_me: error: missing argument to $ac_option" >&2 + { (exit 1); exit 1; }; } +fi + +# Be sure to have absolute paths. +for ac_var in exec_prefix prefix +do + eval ac_val=$`echo $ac_var` + case $ac_val in + [\\/$]* | ?:[\\/]* | NONE | '' ) ;; + *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 + { (exit 1); exit 1; }; };; + esac +done + +# Be sure to have absolute paths. +for ac_var in bindir sbindir libexecdir datadir sysconfdir sharedstatedir \ + localstatedir libdir includedir oldincludedir infodir mandir +do + eval ac_val=$`echo $ac_var` + case $ac_val in + [\\/$]* | ?:[\\/]* ) ;; + *) { echo "$as_me: error: expected an absolute directory name for --$ac_var: $ac_val" >&2 + { (exit 1); exit 1; }; };; + esac +done + +# There might be people who depend on the old broken behavior: `$host' +# used to hold the argument of --host etc. +# FIXME: To remove some day. +build=$build_alias +host=$host_alias +target=$target_alias + +# FIXME: To remove some day. +if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe + echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. + If a cross compiler is detected then cross compile mode will be used." >&2 + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +fi + +ac_tool_prefix= +test -n "$host_alias" && ac_tool_prefix=$host_alias- + +test "$silent" = yes && exec 6>/dev/null + + +# Find the source files, if location was not specified. +if test -z "$srcdir"; then + ac_srcdir_defaulted=yes + # Try the directory containing this script, then its parent. + ac_confdir=`(dirname "$0") 2>/dev/null || +$as_expr X"$0" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$0" : 'X\(//\)[^/]' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$0" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + srcdir=$ac_confdir + if test ! -r $srcdir/$ac_unique_file; then + srcdir=.. + fi +else + ac_srcdir_defaulted=no +fi +if test ! -r $srcdir/$ac_unique_file; then + if test "$ac_srcdir_defaulted" = yes; then + { echo "$as_me: error: cannot find sources ($ac_unique_file) in $ac_confdir or .." >&2 + { (exit 1); exit 1; }; } + else + { echo "$as_me: error: cannot find sources ($ac_unique_file) in $srcdir" >&2 + { (exit 1); exit 1; }; } + fi +fi +(cd $srcdir && test -r ./$ac_unique_file) 2>/dev/null || + { echo "$as_me: error: sources are in $srcdir, but \`cd $srcdir' does not work" >&2 + { (exit 1); exit 1; }; } +srcdir=`echo "$srcdir" | sed 's%\([^\\/]\)[\\/]*$%\1%'` +ac_env_build_alias_set=${build_alias+set} +ac_env_build_alias_value=$build_alias +ac_cv_env_build_alias_set=${build_alias+set} +ac_cv_env_build_alias_value=$build_alias +ac_env_host_alias_set=${host_alias+set} +ac_env_host_alias_value=$host_alias +ac_cv_env_host_alias_set=${host_alias+set} +ac_cv_env_host_alias_value=$host_alias +ac_env_target_alias_set=${target_alias+set} +ac_env_target_alias_value=$target_alias +ac_cv_env_target_alias_set=${target_alias+set} +ac_cv_env_target_alias_value=$target_alias +ac_env_CC_set=${CC+set} +ac_env_CC_value=$CC +ac_cv_env_CC_set=${CC+set} +ac_cv_env_CC_value=$CC +ac_env_CFLAGS_set=${CFLAGS+set} +ac_env_CFLAGS_value=$CFLAGS +ac_cv_env_CFLAGS_set=${CFLAGS+set} +ac_cv_env_CFLAGS_value=$CFLAGS +ac_env_LDFLAGS_set=${LDFLAGS+set} +ac_env_LDFLAGS_value=$LDFLAGS +ac_cv_env_LDFLAGS_set=${LDFLAGS+set} +ac_cv_env_LDFLAGS_value=$LDFLAGS +ac_env_CPPFLAGS_set=${CPPFLAGS+set} +ac_env_CPPFLAGS_value=$CPPFLAGS +ac_cv_env_CPPFLAGS_set=${CPPFLAGS+set} +ac_cv_env_CPPFLAGS_value=$CPPFLAGS +ac_env_CPP_set=${CPP+set} +ac_env_CPP_value=$CPP +ac_cv_env_CPP_set=${CPP+set} +ac_cv_env_CPP_value=$CPP + +# +# Report the --help message. +# +if test "$ac_init_help" = "long"; then + # Omit some internal or obsolete options to make the list less imposing. + # This message is too long to be a string in the A/UX 3.1 sh. + cat <<_ACEOF +\`configure' configures this package to adapt to many kinds of systems. + +Usage: $0 [OPTION]... [VAR=VALUE]... + +To assign environment variables (e.g., CC, CFLAGS...), specify them as +VAR=VALUE. See below for descriptions of some of the useful variables. + +Defaults for the options are specified in brackets. + +Configuration: + -h, --help display this help and exit + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit + -q, --quiet, --silent do not print \`checking...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files + --srcdir=DIR find the sources in DIR [configure dir or \`..'] + +_ACEOF + + cat <<_ACEOF +Installation directories: + --prefix=PREFIX install architecture-independent files in PREFIX + [$ac_default_prefix] + --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX + [PREFIX] + +By default, \`make install' will install all the files in +\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify +an installation prefix other than \`$ac_default_prefix' using \`--prefix', +for instance \`--prefix=\$HOME'. + +For better control, use the options below. + +Fine tuning of the installation directories: + --bindir=DIR user executables [EPREFIX/bin] + --sbindir=DIR system admin executables [EPREFIX/sbin] + --libexecdir=DIR program executables [EPREFIX/libexec] + --datadir=DIR read-only architecture-independent data [PREFIX/share] + --sysconfdir=DIR read-only single-machine data [PREFIX/etc] + --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com] + --localstatedir=DIR modifiable single-machine data [PREFIX/var] + --libdir=DIR object code libraries [EPREFIX/lib] + --includedir=DIR C header files [PREFIX/include] + --oldincludedir=DIR C header files for non-gcc [/usr/include] + --infodir=DIR info documentation [PREFIX/info] + --mandir=DIR man documentation [PREFIX/man] +_ACEOF + + cat <<\_ACEOF + +System types: + --build=BUILD configure for building on BUILD [guessed] + --host=HOST cross-compile to build programs to run on HOST [BUILD] + --target=TARGET configure for building compilers for TARGET [HOST] +_ACEOF +fi + +if test -n "$ac_init_help"; then + + cat <<\_ACEOF + +Optional Packages: + --with-PACKAGE[=ARG] use PACKAGE [ARG=yes] + --without-PACKAGE do not use PACKAGE (same as --with-PACKAGE=no) + --with-blockinggraph enable the blocking graph feature + --with-rand enable the randomized value numbering + --with-arithabs enable the arithmetic abstraction + --with-zrapp enable the zrapp pretty-printer + +Some influential environment variables: + CC C compiler command + CFLAGS C compiler flags + LDFLAGS linker flags, e.g. -L if you have libraries in a + nonstandard directory + CPPFLAGS C/C++ preprocessor flags, e.g. -I if you have + headers in a nonstandard directory + CPP C preprocessor + +Use these variables to override the choices made by `configure' or to help +it to find libraries and programs with nonstandard names/locations. + +_ACEOF +fi + +if test "$ac_init_help" = "recursive"; then + # If there are subdirs, report their specific --help. + ac_popdir=`pwd` + for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue + test -d $ac_dir || continue + ac_builddir=. + +if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` +else + ac_dir_suffix= ac_top_builddir= +fi + +case $srcdir in + .) # No --srcdir option. We are building in place. + ac_srcdir=. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; +esac + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac + + cd $ac_dir + # Check for guested configure; otherwise get Cygnus style configure. + if test -f $ac_srcdir/configure.gnu; then + echo + $SHELL $ac_srcdir/configure.gnu --help=recursive + elif test -f $ac_srcdir/configure; then + echo + $SHELL $ac_srcdir/configure --help=recursive + elif test -f $ac_srcdir/configure.ac || + test -f $ac_srcdir/configure.in; then + echo + $ac_configure --help + else + echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2 + fi + cd $ac_popdir + done +fi + +test -n "$ac_init_help" && exit 0 +if $ac_init_version; then + cat <<\_ACEOF + +Copyright (C) 2003 Free Software Foundation, Inc. +This configure script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it. +_ACEOF + exit 0 +fi +exec 5>config.log +cat >&5 <<_ACEOF +This file contains any messages produced by compilers while +running configure, to aid debugging if configure makes a mistake. + +It was created by $as_me, which was +generated by GNU Autoconf 2.59. Invocation command line was + + $ $0 $@ + +_ACEOF +{ +cat <<_ASUNAME +## --------- ## +## Platform. ## +## --------- ## + +hostname = `(hostname || uname -n) 2>/dev/null | sed 1q` +uname -m = `(uname -m) 2>/dev/null || echo unknown` +uname -r = `(uname -r) 2>/dev/null || echo unknown` +uname -s = `(uname -s) 2>/dev/null || echo unknown` +uname -v = `(uname -v) 2>/dev/null || echo unknown` + +/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown` +/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown` + +/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown` +/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown` +/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown` +hostinfo = `(hostinfo) 2>/dev/null || echo unknown` +/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown` +/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown` +/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown` + +_ASUNAME + +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + echo "PATH: $as_dir" +done + +} >&5 + +cat >&5 <<_ACEOF + + +## ----------- ## +## Core tests. ## +## ----------- ## + +_ACEOF + + +# Keep a trace of the command line. +# Strip out --no-create and --no-recursion so they do not pile up. +# Strip out --silent because we don't want to record it for future runs. +# Also quote any args containing shell meta-characters. +# Make two passes to allow for proper duplicate-argument suppression. +ac_configure_args= +ac_configure_args0= +ac_configure_args1= +ac_sep= +ac_must_keep_next=false +for ac_pass in 1 2 +do + for ac_arg + do + case $ac_arg in + -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil) + continue ;; + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) + ac_arg=`echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;; + esac + case $ac_pass in + 1) ac_configure_args0="$ac_configure_args0 '$ac_arg'" ;; + 2) + ac_configure_args1="$ac_configure_args1 '$ac_arg'" + if test $ac_must_keep_next = true; then + ac_must_keep_next=false # Got value, back to normal. + else + case $ac_arg in + *=* | --config-cache | -C | -disable-* | --disable-* \ + | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \ + | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \ + | -with-* | --with-* | -without-* | --without-* | --x) + case "$ac_configure_args0 " in + "$ac_configure_args1"*" '$ac_arg' "* ) continue ;; + esac + ;; + -* ) ac_must_keep_next=true ;; + esac + fi + ac_configure_args="$ac_configure_args$ac_sep'$ac_arg'" + # Get rid of the leading space. + ac_sep=" " + ;; + esac + done +done +$as_unset ac_configure_args0 || test "${ac_configure_args0+set}" != set || { ac_configure_args0=; export ac_configure_args0; } +$as_unset ac_configure_args1 || test "${ac_configure_args1+set}" != set || { ac_configure_args1=; export ac_configure_args1; } + +# When interrupted or exit'd, cleanup temporary files, and complete +# config.log. We remove comments because anyway the quotes in there +# would cause problems or look ugly. +# WARNING: Be sure not to use single quotes in there, as some shells, +# such as our DU 5.0 friend, will then `close' the trap. +trap 'exit_status=$? + # Save into config.log some information that might help in debugging. + { + echo + + cat <<\_ASBOX +## ---------------- ## +## Cache variables. ## +## ---------------- ## +_ASBOX + echo + # The following way of writing the cache mishandles newlines in values, +{ + (set) 2>&1 | + case `(ac_space='"'"' '"'"'; set | grep ac_space) 2>&1` in + *ac_space=\ *) + sed -n \ + "s/'"'"'/'"'"'\\\\'"'"''"'"'/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='"'"'\\2'"'"'/p" + ;; + *) + sed -n \ + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" + ;; + esac; +} + echo + + cat <<\_ASBOX +## ----------------- ## +## Output variables. ## +## ----------------- ## +_ASBOX + echo + for ac_var in $ac_subst_vars + do + eval ac_val=$`echo $ac_var` + echo "$ac_var='"'"'$ac_val'"'"'" + done | sort + echo + + if test -n "$ac_subst_files"; then + cat <<\_ASBOX +## ------------- ## +## Output files. ## +## ------------- ## +_ASBOX + echo + for ac_var in $ac_subst_files + do + eval ac_val=$`echo $ac_var` + echo "$ac_var='"'"'$ac_val'"'"'" + done | sort + echo + fi + + if test -s confdefs.h; then + cat <<\_ASBOX +## ----------- ## +## confdefs.h. ## +## ----------- ## +_ASBOX + echo + sed "/^$/d" confdefs.h | sort + echo + fi + test "$ac_signal" != 0 && + echo "$as_me: caught signal $ac_signal" + echo "$as_me: exit $exit_status" + } >&5 + rm -f core *.core && + rm -rf conftest* confdefs* conf$$* $ac_clean_files && + exit $exit_status + ' 0 +for ac_signal in 1 2 13 15; do + trap 'ac_signal='$ac_signal'; { (exit 1); exit 1; }' $ac_signal +done +ac_signal=0 + +# confdefs.h avoids OS command line length limits that DEFS can exceed. +rm -rf conftest* confdefs.h +# AIX cpp loses on an empty file, so make sure it contains at least a newline. +echo >confdefs.h + +# Predefined preprocessor variables. + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_NAME "$PACKAGE_NAME" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_TARNAME "$PACKAGE_TARNAME" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_VERSION "$PACKAGE_VERSION" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_STRING "$PACKAGE_STRING" +_ACEOF + + +cat >>confdefs.h <<_ACEOF +#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT" +_ACEOF + + +# Let the site file select an alternate cache file if it wants to. +# Prefer explicitly selected file to automatically selected ones. +if test -z "$CONFIG_SITE"; then + if test "x$prefix" != xNONE; then + CONFIG_SITE="$prefix/share/config.site $prefix/etc/config.site" + else + CONFIG_SITE="$ac_default_prefix/share/config.site $ac_default_prefix/etc/config.site" + fi +fi +for ac_site_file in $CONFIG_SITE; do + if test -r "$ac_site_file"; then + { echo "$as_me:$LINENO: loading site script $ac_site_file" >&5 +echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 + . "$ac_site_file" + fi +done + +if test -r "$cache_file"; then + # Some versions of bash will fail to source /dev/null (special + # files actually), so we avoid doing that. + if test -f "$cache_file"; then + { echo "$as_me:$LINENO: loading cache $cache_file" >&5 +echo "$as_me: loading cache $cache_file" >&6;} + case $cache_file in + [\\/]* | ?:[\\/]* ) . $cache_file;; + *) . ./$cache_file;; + esac + fi +else + { echo "$as_me:$LINENO: creating cache $cache_file" >&5 +echo "$as_me: creating cache $cache_file" >&6;} + >$cache_file +fi + +# Check that the precious variables saved in the cache have kept the same +# value. +ac_cache_corrupted=false +for ac_var in `(set) 2>&1 | + sed -n 's/^ac_env_\([a-zA-Z_0-9]*\)_set=.*/\1/p'`; do + eval ac_old_set=\$ac_cv_env_${ac_var}_set + eval ac_new_set=\$ac_env_${ac_var}_set + eval ac_old_val="\$ac_cv_env_${ac_var}_value" + eval ac_new_val="\$ac_env_${ac_var}_value" + case $ac_old_set,$ac_new_set in + set,) + { echo "$as_me:$LINENO: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5 +echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,set) + { echo "$as_me:$LINENO: error: \`$ac_var' was not set in the previous run" >&5 +echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;} + ac_cache_corrupted=: ;; + ,);; + *) + if test "x$ac_old_val" != "x$ac_new_val"; then + { echo "$as_me:$LINENO: error: \`$ac_var' has changed since the previous run:" >&5 +echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;} + { echo "$as_me:$LINENO: former value: $ac_old_val" >&5 +echo "$as_me: former value: $ac_old_val" >&2;} + { echo "$as_me:$LINENO: current value: $ac_new_val" >&5 +echo "$as_me: current value: $ac_new_val" >&2;} + ac_cache_corrupted=: + fi;; + esac + # Pass precious variables to config.status. + if test "$ac_new_set" = set; then + case $ac_new_val in + *" "*|*" "*|*[\[\]\~\#\$\^\&\*\(\)\{\}\\\|\;\<\>\?\"\']*) + ac_arg=$ac_var=`echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;; + *) ac_arg=$ac_var=$ac_new_val ;; + esac + case " $ac_configure_args " in + *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy. + *) ac_configure_args="$ac_configure_args '$ac_arg'" ;; + esac + fi +done +if $ac_cache_corrupted; then + { echo "$as_me:$LINENO: error: changes in the environment can compromise the build" >&5 +echo "$as_me: error: changes in the environment can compromise the build" >&2;} + { { echo "$as_me:$LINENO: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&5 +echo "$as_me: error: run \`make distclean' and/or \`rm $cache_file' and start over" >&2;} + { (exit 1); exit 1; }; } +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + + + + + + + + + + + + + + + + + + + ac_config_headers="$ac_config_headers config.h" + + +# sm: require a late-enough autoconf; this is the version number +# that's on manju, so I assume it's ok + + +# +# Assign here the CIL version numbers +CIL_VERSION_MAJOR=1 +CIL_VERSION_MINOR=3 +CIL_VERSION_REV=5 +CIL_VERSION=$CIL_VERSION_MAJOR.$CIL_VERSION_MINOR.$CIL_VERSION_REV + + +# make sure I haven't forgotten to run autoconf +if test configure -ot configure.in; then + { { echo "$as_me:$LINENO: error: configure is older than configure.in; you forgot to run autoconf" >&5 +echo "$as_me: error: configure is older than configure.in; you forgot to run autoconf" >&2;} + { (exit 1); exit 1; }; } +fi + +# check for C compiler; this typically finds gcc; it sets the +# variable CC to whatever it finds, which then gets substituted +# for @CC@ in output files; you have to do this even if you don't +# care about @CC@, because system feature tests later on in +# the ./configure script will expect $CC to be set right +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args. +set dummy ${ac_tool_prefix}gcc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}gcc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "gcc", so it can be a program name with args. +set dummy gcc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="gcc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + CC=$ac_ct_CC +else + CC="$ac_cv_prog_CC" +fi + +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args. +set dummy ${ac_tool_prefix}cc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="${ac_tool_prefix}cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + +fi +if test -z "$ac_cv_prog_CC"; then + ac_ct_CC=$CC + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + CC=$ac_ct_CC +else + CC="$ac_cv_prog_CC" +fi + +fi +if test -z "$CC"; then + # Extract the first word of "cc", so it can be a program name with args. +set dummy cc; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else + ac_prog_rejected=no +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then + ac_prog_rejected=yes + continue + fi + ac_cv_prog_CC="cc" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +if test $ac_prog_rejected = yes; then + # We found a bogon in the path, so make sure we never use it. + set dummy $ac_cv_prog_CC + shift + if test $# != 0; then + # We chose a different compiler from the bogus one. + # However, it has the same basename, so the bogon will be chosen + # first if we set CC to just the basename; use the full file name. + shift + ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@" + fi +fi +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + +fi +if test -z "$CC"; then + if test -n "$ac_tool_prefix"; then + for ac_prog in cl + do + # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args. +set dummy $ac_tool_prefix$ac_prog; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$CC"; then + ac_cv_prog_CC="$CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_CC="$ac_tool_prefix$ac_prog" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +CC=$ac_cv_prog_CC +if test -n "$CC"; then + echo "$as_me:$LINENO: result: $CC" >&5 +echo "${ECHO_T}$CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + test -n "$CC" && break + done +fi +if test -z "$CC"; then + ac_ct_CC=$CC + for ac_prog in cl +do + # Extract the first word of "$ac_prog", so it can be a program name with args. +set dummy $ac_prog; ac_word=$2 +echo "$as_me:$LINENO: checking for $ac_word" >&5 +echo $ECHO_N "checking for $ac_word... $ECHO_C" >&6 +if test "${ac_cv_prog_ac_ct_CC+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test -n "$ac_ct_CC"; then + ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test. +else +as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_word$ac_exec_ext"; then + ac_cv_prog_ac_ct_CC="$ac_prog" + echo "$as_me:$LINENO: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done +done + +fi +fi +ac_ct_CC=$ac_cv_prog_ac_ct_CC +if test -n "$ac_ct_CC"; then + echo "$as_me:$LINENO: result: $ac_ct_CC" >&5 +echo "${ECHO_T}$ac_ct_CC" >&6 +else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 +fi + + test -n "$ac_ct_CC" && break +done + + CC=$ac_ct_CC +fi + +fi + + +test -z "$CC" && { { echo "$as_me:$LINENO: error: no acceptable C compiler found in \$PATH +See \`config.log' for more details." >&5 +echo "$as_me: error: no acceptable C compiler found in \$PATH +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } + +# Provide some information about the compiler. +echo "$as_me:$LINENO:" \ + "checking for C compiler version" >&5 +ac_compiler=`set X $ac_compile; echo $2` +{ (eval echo "$as_me:$LINENO: \"$ac_compiler --version &5\"") >&5 + (eval $ac_compiler --version &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } +{ (eval echo "$as_me:$LINENO: \"$ac_compiler -v &5\"") >&5 + (eval $ac_compiler -v &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } +{ (eval echo "$as_me:$LINENO: \"$ac_compiler -V &5\"") >&5 + (eval $ac_compiler -V &5) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } + +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files a.out a.exe b.out" +# Try to create an executable without -o first, disregard a.out. +# It will help us diagnose broken compilers, and finding out an intuition +# of exeext. +echo "$as_me:$LINENO: checking for C compiler default output file name" >&5 +echo $ECHO_N "checking for C compiler default output file name... $ECHO_C" >&6 +ac_link_default=`echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'` +if { (eval echo "$as_me:$LINENO: \"$ac_link_default\"") >&5 + (eval $ac_link_default) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + # Find the output, starting from the most likely. This scheme is +# not robust to junk in `.', hence go to wildcards (a.*) only as a last +# resort. + +# Be careful to initialize this variable, since it used to be cached. +# Otherwise an old cache value of `no' led to `EXEEXT = no' in a Makefile. +ac_cv_exeext= +# b.out is created by i960 compilers. +for ac_file in a_out.exe a.exe conftest.exe a.out conftest a.* conftest.* b.out +do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) + ;; + conftest.$ac_ext ) + # This is the source file. + ;; + [ab].out ) + # We found the default executable, but exeext='' is most + # certainly right. + break;; + *.* ) + ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + # FIXME: I believe we export ac_cv_exeext for Libtool, + # but it would be cool to find out if it's true. Does anybody + # maintain Libtool? --akim. + export ac_cv_exeext + break;; + * ) + break;; + esac +done +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { echo "$as_me:$LINENO: error: C compiler cannot create executables +See \`config.log' for more details." >&5 +echo "$as_me: error: C compiler cannot create executables +See \`config.log' for more details." >&2;} + { (exit 77); exit 77; }; } +fi + +ac_exeext=$ac_cv_exeext +echo "$as_me:$LINENO: result: $ac_file" >&5 +echo "${ECHO_T}$ac_file" >&6 + +# Check the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +echo "$as_me:$LINENO: checking whether the C compiler works" >&5 +echo $ECHO_N "checking whether the C compiler works... $ECHO_C" >&6 +# FIXME: These cross compiler hacks should be removed for Autoconf 3.0 +# If not cross compiling, check that we can run a simple program. +if test "$cross_compiling" != yes; then + if { ac_try='./$ac_file' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + cross_compiling=no + else + if test "$cross_compiling" = maybe; then + cross_compiling=yes + else + { { echo "$as_me:$LINENO: error: cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot run C compiled programs. +If you meant to cross compile, use \`--host'. +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } + fi + fi +fi +echo "$as_me:$LINENO: result: yes" >&5 +echo "${ECHO_T}yes" >&6 + +rm -f a.out a.exe conftest$ac_cv_exeext b.out +ac_clean_files=$ac_clean_files_save +# Check the compiler produces executables we can run. If not, either +# the compiler is broken, or we cross compile. +echo "$as_me:$LINENO: checking whether we are cross compiling" >&5 +echo $ECHO_N "checking whether we are cross compiling... $ECHO_C" >&6 +echo "$as_me:$LINENO: result: $cross_compiling" >&5 +echo "${ECHO_T}$cross_compiling" >&6 + +echo "$as_me:$LINENO: checking for suffix of executables" >&5 +echo $ECHO_N "checking for suffix of executables... $ECHO_C" >&6 +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + # If both `conftest.exe' and `conftest' are `present' (well, observable) +# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will +# work properly (i.e., refer to `conftest.exe'), while it won't with +# `rm'. +for ac_file in conftest.exe conftest conftest.*; do + test -f "$ac_file" || continue + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.o | *.obj ) ;; + *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'` + export ac_cv_exeext + break;; + * ) break;; + esac +done +else + { { echo "$as_me:$LINENO: error: cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot compute suffix of executables: cannot compile and link +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } +fi + +rm -f conftest$ac_cv_exeext +echo "$as_me:$LINENO: result: $ac_cv_exeext" >&5 +echo "${ECHO_T}$ac_cv_exeext" >&6 + +rm -f conftest.$ac_ext +EXEEXT=$ac_cv_exeext +ac_exeext=$EXEEXT +echo "$as_me:$LINENO: checking for suffix of object files" >&5 +echo $ECHO_N "checking for suffix of object files... $ECHO_C" >&6 +if test "${ac_cv_objext+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.o conftest.obj +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; then + for ac_file in `(ls conftest.o conftest.obj; ls conftest.*) 2>/dev/null`; do + case $ac_file in + *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg ) ;; + *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'` + break;; + esac +done +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +{ { echo "$as_me:$LINENO: error: cannot compute suffix of object files: cannot compile +See \`config.log' for more details." >&5 +echo "$as_me: error: cannot compute suffix of object files: cannot compile +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } +fi + +rm -f conftest.$ac_cv_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_objext" >&5 +echo "${ECHO_T}$ac_cv_objext" >&6 +OBJEXT=$ac_cv_objext +ac_objext=$OBJEXT +echo "$as_me:$LINENO: checking whether we are using the GNU C compiler" >&5 +echo $ECHO_N "checking whether we are using the GNU C compiler... $ECHO_C" >&6 +if test "${ac_cv_c_compiler_gnu+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ +#ifndef __GNUC__ + choke me +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_compiler_gnu=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_compiler_gnu=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +ac_cv_c_compiler_gnu=$ac_compiler_gnu + +fi +echo "$as_me:$LINENO: result: $ac_cv_c_compiler_gnu" >&5 +echo "${ECHO_T}$ac_cv_c_compiler_gnu" >&6 +GCC=`test $ac_compiler_gnu = yes && echo yes` +ac_test_CFLAGS=${CFLAGS+set} +ac_save_CFLAGS=$CFLAGS +CFLAGS="-g" +echo "$as_me:$LINENO: checking whether $CC accepts -g" >&5 +echo $ECHO_N "checking whether $CC accepts -g... $ECHO_C" >&6 +if test "${ac_cv_prog_cc_g+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_g=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_prog_cc_g=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_prog_cc_g" >&5 +echo "${ECHO_T}$ac_cv_prog_cc_g" >&6 +if test "$ac_test_CFLAGS" = set; then + CFLAGS=$ac_save_CFLAGS +elif test $ac_cv_prog_cc_g = yes; then + if test "$GCC" = yes; then + CFLAGS="-g -O2" + else + CFLAGS="-g" + fi +else + if test "$GCC" = yes; then + CFLAGS="-O2" + else + CFLAGS= + fi +fi +echo "$as_me:$LINENO: checking for $CC option to accept ANSI C" >&5 +echo $ECHO_N "checking for $CC option to accept ANSI C... $ECHO_C" >&6 +if test "${ac_cv_prog_cc_stdc+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_prog_cc_stdc=no +ac_save_CC=$CC +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +#include +#include +#include +/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */ +struct buf { int x; }; +FILE * (*rcsopen) (struct buf *, struct stat *, int); +static char *e (p, i) + char **p; + int i; +{ + return p[i]; +} +static char *f (char * (*g) (char **, int), char **p, ...) +{ + char *s; + va_list v; + va_start (v,p); + s = g (p, va_arg (v,int)); + va_end (v); + return s; +} + +/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has + function prototypes and stuff, but not '\xHH' hex character constants. + These don't provoke an error unfortunately, instead are silently treated + as 'x'. The following induces an error, until -std1 is added to get + proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an + array size at least. It's necessary to write '\x00'==0 to get something + that's true only with -std1. */ +int osf4_cc_array ['\x00' == 0 ? 1 : -1]; + +int test (int i, double x); +struct s1 {int (*f) (int a);}; +struct s2 {int (*f) (double a);}; +int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int); +int argc; +char **argv; +int +main () +{ +return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1]; + ; + return 0; +} +_ACEOF +# Don't try gcc -ansi; that turns off useful extensions and +# breaks some systems' header files. +# AIX -qlanglvl=ansi +# Ultrix and OSF/1 -std1 +# HP-UX 10.20 and later -Ae +# HP-UX older versions -Aa -D_HPUX_SOURCE +# SVR4 -Xc -D__EXTENSIONS__ +for ac_arg in "" -qlanglvl=ansi -std1 -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__" +do + CC="$ac_save_CC $ac_arg" + rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_prog_cc_stdc=$ac_arg +break +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +fi +rm -f conftest.err conftest.$ac_objext +done +rm -f conftest.$ac_ext conftest.$ac_objext +CC=$ac_save_CC + +fi + +case "x$ac_cv_prog_cc_stdc" in + x|xno) + echo "$as_me:$LINENO: result: none needed" >&5 +echo "${ECHO_T}none needed" >&6 ;; + *) + echo "$as_me:$LINENO: result: $ac_cv_prog_cc_stdc" >&5 +echo "${ECHO_T}$ac_cv_prog_cc_stdc" >&6 + CC="$CC $ac_cv_prog_cc_stdc" ;; +esac + +# Some people use a C++ compiler to compile C. Since we use `exit', +# in C++ we need to declare it. In case someone uses the same compiler +# for both compiling C and C++ we need to have the C++ compiler decide +# the declaration of exit, since it's the most demanding environment. +cat >conftest.$ac_ext <<_ACEOF +#ifndef __cplusplus + choke me +#endif +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + for ac_declaration in \ + '' \ + 'extern "C" void std::exit (int) throw (); using std::exit;' \ + 'extern "C" void std::exit (int); using std::exit;' \ + 'extern "C" void exit (int) throw ();' \ + 'extern "C" void exit (int);' \ + 'void exit (int);' +do + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_declaration +#include +int +main () +{ +exit (42); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +continue +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_declaration +int +main () +{ +exit (42); + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + break +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +done +rm -f conftest* +if test -n "$ac_declaration"; then + echo '#ifdef __cplusplus' >>confdefs.h + echo $ac_declaration >>confdefs.h + echo '#endif' >>confdefs.h +fi + +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +ac_aux_dir= +for ac_dir in $srcdir $srcdir/.. $srcdir/../..; do + if test -f $ac_dir/install-sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install-sh -c" + break + elif test -f $ac_dir/install.sh; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/install.sh -c" + break + elif test -f $ac_dir/shtool; then + ac_aux_dir=$ac_dir + ac_install_sh="$ac_aux_dir/shtool install -c" + break + fi +done +if test -z "$ac_aux_dir"; then + { { echo "$as_me:$LINENO: error: cannot find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." >&5 +echo "$as_me: error: cannot find install-sh or install.sh in $srcdir $srcdir/.. $srcdir/../.." >&2;} + { (exit 1); exit 1; }; } +fi +ac_config_guess="$SHELL $ac_aux_dir/config.guess" +ac_config_sub="$SHELL $ac_aux_dir/config.sub" +ac_configure="$SHELL $ac_aux_dir/configure" # This should be Cygnus configure. + +# Find a good install program. We prefer a C program (faster), +# so one script is as good as another. But avoid the broken or +# incompatible versions: +# SysV /etc/install, /usr/sbin/install +# SunOS /usr/etc/install +# IRIX /sbin/install +# AIX /bin/install +# AmigaOS /C/install, which installs bootblocks on floppy discs +# AIX 4 /usr/bin/installbsd, which doesn't work without a -g flag +# AFS /usr/afsws/bin/install, which mishandles nonexistent args +# SVR4 /usr/ucb/install, which tries to use the nonexistent group "staff" +# OS/2's system install, which has a completely different semantic +# ./install, which can be erroneously created by make from ./install.sh. +echo "$as_me:$LINENO: checking for a BSD-compatible install" >&5 +echo $ECHO_N "checking for a BSD-compatible install... $ECHO_C" >&6 +if test -z "$INSTALL"; then +if test "${ac_cv_path_install+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + # Account for people who put trailing slashes in PATH elements. +case $as_dir/ in + ./ | .// | /cC/* | \ + /etc/* | /usr/sbin/* | /usr/etc/* | /sbin/* | /usr/afsws/bin/* | \ + ?:\\/os2\\/install\\/* | ?:\\/OS2\\/INSTALL\\/* | \ + /usr/ucb/* ) ;; + *) + # OSF1 and SCO ODT 3.0 have their own names for install. + # Don't use installbsd from OSF since it installs stuff as root + # by default. + for ac_prog in ginstall scoinst install; do + for ac_exec_ext in '' $ac_executable_extensions; do + if $as_executable_p "$as_dir/$ac_prog$ac_exec_ext"; then + if test $ac_prog = install && + grep dspmsg "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then + # AIX install. It has an incompatible calling convention. + : + elif test $ac_prog = install && + grep pwplus "$as_dir/$ac_prog$ac_exec_ext" >/dev/null 2>&1; then + # program-specific install script used by HP pwplus--don't use. + : + else + ac_cv_path_install="$as_dir/$ac_prog$ac_exec_ext -c" + break 3 + fi + fi + done + done + ;; +esac +done + + +fi + if test "${ac_cv_path_install+set}" = set; then + INSTALL=$ac_cv_path_install + else + # As a last resort, use the slow shell script. We don't cache a + # path for INSTALL within a source directory, because that will + # break other packages using the cache if that directory is + # removed, or if the path is relative. + INSTALL=$ac_install_sh + fi +fi +echo "$as_me:$LINENO: result: $INSTALL" >&5 +echo "${ECHO_T}$INSTALL" >&6 + +# Use test -z because SunOS4 sh mishandles braces in ${var-val}. +# It thinks the first close brace ends the variable substitution. +test -z "$INSTALL_PROGRAM" && INSTALL_PROGRAM='${INSTALL}' + +test -z "$INSTALL_SCRIPT" && INSTALL_SCRIPT='${INSTALL}' + +test -z "$INSTALL_DATA" && INSTALL_DATA='${INSTALL} -m 644' + + + +# find system type (using this macro means we must include +# the files install-sh, config.sub, and config.guess (all from +# the autoconf distribution) in our source tree!) +# Make sure we can run config.sub. +$ac_config_sub sun4 >/dev/null 2>&1 || + { { echo "$as_me:$LINENO: error: cannot run $ac_config_sub" >&5 +echo "$as_me: error: cannot run $ac_config_sub" >&2;} + { (exit 1); exit 1; }; } + +echo "$as_me:$LINENO: checking build system type" >&5 +echo $ECHO_N "checking build system type... $ECHO_C" >&6 +if test "${ac_cv_build+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_build_alias=$build_alias +test -z "$ac_cv_build_alias" && + ac_cv_build_alias=`$ac_config_guess` +test -z "$ac_cv_build_alias" && + { { echo "$as_me:$LINENO: error: cannot guess build type; you must specify one" >&5 +echo "$as_me: error: cannot guess build type; you must specify one" >&2;} + { (exit 1); exit 1; }; } +ac_cv_build=`$ac_config_sub $ac_cv_build_alias` || + { { echo "$as_me:$LINENO: error: $ac_config_sub $ac_cv_build_alias failed" >&5 +echo "$as_me: error: $ac_config_sub $ac_cv_build_alias failed" >&2;} + { (exit 1); exit 1; }; } + +fi +echo "$as_me:$LINENO: result: $ac_cv_build" >&5 +echo "${ECHO_T}$ac_cv_build" >&6 +build=$ac_cv_build +build_cpu=`echo $ac_cv_build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` +build_vendor=`echo $ac_cv_build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` +build_os=`echo $ac_cv_build | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` + + +echo "$as_me:$LINENO: checking host system type" >&5 +echo $ECHO_N "checking host system type... $ECHO_C" >&6 +if test "${ac_cv_host+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_host_alias=$host_alias +test -z "$ac_cv_host_alias" && + ac_cv_host_alias=$ac_cv_build_alias +ac_cv_host=`$ac_config_sub $ac_cv_host_alias` || + { { echo "$as_me:$LINENO: error: $ac_config_sub $ac_cv_host_alias failed" >&5 +echo "$as_me: error: $ac_config_sub $ac_cv_host_alias failed" >&2;} + { (exit 1); exit 1; }; } + +fi +echo "$as_me:$LINENO: result: $ac_cv_host" >&5 +echo "${ECHO_T}$ac_cv_host" >&6 +host=$ac_cv_host +host_cpu=`echo $ac_cv_host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` +host_vendor=`echo $ac_cv_host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` +host_os=`echo $ac_cv_host | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` + + +echo "$as_me:$LINENO: checking target system type" >&5 +echo $ECHO_N "checking target system type... $ECHO_C" >&6 +if test "${ac_cv_target+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_target_alias=$target_alias +test "x$ac_cv_target_alias" = "x" && + ac_cv_target_alias=$ac_cv_host_alias +ac_cv_target=`$ac_config_sub $ac_cv_target_alias` || + { { echo "$as_me:$LINENO: error: $ac_config_sub $ac_cv_target_alias failed" >&5 +echo "$as_me: error: $ac_config_sub $ac_cv_target_alias failed" >&2;} + { (exit 1); exit 1; }; } + +fi +echo "$as_me:$LINENO: result: $ac_cv_target" >&5 +echo "${ECHO_T}$ac_cv_target" >&6 +target=$ac_cv_target +target_cpu=`echo $ac_cv_target | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\1/'` +target_vendor=`echo $ac_cv_target | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\2/'` +target_os=`echo $ac_cv_target | sed 's/^\([^-]*\)-\([^-]*\)-\(.*\)$/\3/'` + + +# The aliases save the names the user supplied, while $host etc. +# will get canonicalized. +test -n "$target_alias" && + test "$program_prefix$program_suffix$program_transform_name" = \ + NONENONEs,x,x, && + program_prefix=${target_alias}- + + +# ---------------- generic functions ----------------- +# debugging diagnostic; set to 'echo' to debug or 'true' for production +# (technically you're not supposed to use shell functions in +# configure scripts, because some-obscure-sh somewhere doesn't +# support them.. but they're too convenient to not use) +diagnostic() { + #echo "$@" + true "$@" +} + +# determine if a binary is in the path +binaryExists() { + # on cygwin, 'which' always returns success, so use 'type' instead + if type "$1" >/dev/null 2>&1; then + return 0 + else + return 1 + fi +} + + +# -------------- portable configuration ---------------- +# this specifies the root of the source tree; it's just the +# directory where ./configure runs, except on cygwin, which +# overrides this below +CILHOME=`pwd` + +DEFAULT_COMPILER=_GNUCC +DEFAULT_CIL_MODE=GNUCC + +# is the microsoft compiler available? +# hmm.. I think we should check the version or something, because +# sometimes people have Common Lisp's interpreter called 'cl' .. +echo "$as_me:$LINENO: checking for msvc cl.exe (optional)" >&5 +echo $ECHO_N "checking for msvc cl.exe (optional)... $ECHO_C" >&6 +# See if CC points to the MS compiler +if "$CC" 2>&1 | grep "Microsoft" >/dev/null; then + echo "$as_me:$LINENO: result: found, set as default" >&5 +echo "${ECHO_T}found, set as default" >&6 + HAS_MSVC=yes + DEFAULT_COMPILER=_MSVC + DEFAULT_CIL_MODE=MSVC +else + if cl 2>&1 | grep "Microsoft" >/dev/null ;then + echo "$as_me:$LINENO: result: found" >&5 +echo "${ECHO_T}found" >&6 + HAS_MSVC=yes + else + echo "$as_me:$LINENO: result: not found" >&5 +echo "${ECHO_T}not found" >&6 + HAS_MSVC=no + fi +fi + +# is ocaml available? +# needed binaries: ocamllex ocamlyacc ocamldep ocamlopt ocamlc +ocamlDownloadInstructions=" + OCaml can be downloaded from http://caml.inria.fr/ocaml/. + After downloading and unpacking the source distribution, in the ocaml + directory, do + ./configure + make world + make opt + make install + Then come back here and re-run ./configure." + +# required major/minor. +# required major/minor +reqMaj=3 +reqMin=08 +knownMaj=3 +knownMin=09 +echo "$as_me:$LINENO: checking ocaml version is at least $reqMaj.$reqMin" >&5 +echo $ECHO_N "checking ocaml version is at least $reqMaj.$reqMin... $ECHO_C" >&6 +if binaryExists ocamlc; then + # what version? + ver=`ocamlc -v | grep version | sed 's/^.*version //'` + diagnostic "ver is $ver" + # major: anything before the . + major=`echo $ver | sed 's/\..*$//'` + diagnostic "major is $major" + # minor: numbers after the . + # (the outer level of bracket-quotation protects the inner brackets) + minor=`echo $ver | sed 's/^[^.]*\.\([0-9][0-9]*\).*$/\1/'` + diagnostic "minor is $minor" + + # I would think autoconf would already have a facility for doing + # these kinds of major/minor version checks, but I can't find it + if test $major -gt $reqMaj -o $major -ge $reqMaj -a $minor -ge $reqMin; then + echo "$as_me:$LINENO: result: version is $ver, ok" >&5 +echo "${ECHO_T}version is $ver, ok" >&6 + + # sm: added this test when we found that CCured needed to be changed + # a little when 3.06 came out (it had previously worked with 3.04) + if test "$major" -gt $knownMaj -o "$major" -ge $knownMaj -a "$minor" -gt $knownMin; then + { echo "$as_me:$LINENO: WARNING: Your ocaml version is $ver, but the latest version this program + is known to work with is $knownMaj.$knownMin. If you have + trouble compiling, please try using an earlier version + or see if there is a later version of this program." >&5 +echo "$as_me: WARNING: Your ocaml version is $ver, but the latest version this program + is known to work with is $knownMaj.$knownMin. If you have + trouble compiling, please try using an earlier version + or see if there is a later version of this program." >&2;} + fi + else + { { echo "$as_me:$LINENO: error: + I found OCaml version $ver; this program requires at least $reqMaj.$reqMin. + Please download a newer OCaml distribution. + $ocamlDownloadInstructions + " >&5 +echo "$as_me: error: + I found OCaml version $ver; this program requires at least $reqMaj.$reqMin. + Please download a newer OCaml distribution. + $ocamlDownloadInstructions + " >&2;} + { (exit 1); exit 1; }; } + fi + + # check for existence of other binaries + echo "$as_me:$LINENO: checking existence of related ocaml tools" >&5 +echo $ECHO_N "checking existence of related ocaml tools... $ECHO_C" >&6 + if binaryExists ocamllex && \ + binaryExists ocamlyacc && \ + binaryExists ocamldep && \ + binaryExists ocamlopt; then + echo "$as_me:$LINENO: result: ok" >&5 +echo "${ECHO_T}ok" >&6 + else + { { echo "$as_me:$LINENO: error: + At least one of ocamllex, ocamlyacc, ocamldep or ocamlopt is missing. + In particular, ocamlopt requires you to \"make opt\" when building + OCaml from source. Please make sure all these tools are built and + in the path. + " >&5 +echo "$as_me: error: + At least one of ocamllex, ocamlyacc, ocamldep or ocamlopt is missing. + In particular, ocamlopt requires you to \"make opt\" when building + OCaml from source. Please make sure all these tools are built and + in the path. + " >&2;} + { (exit 1); exit 1; }; } + fi +else + { { echo "$as_me:$LINENO: error: + The \"ocamlc\" OCaml compiler was not found in the path: $PATH. + + Most of this program is written in the OCaml language, so its compiler + is required. + $ocamlDownloadInstructions + " >&5 +echo "$as_me: error: + The \"ocamlc\" OCaml compiler was not found in the path: $PATH. + + Most of this program is written in the OCaml language, so its compiler + is required. + $ocamlDownloadInstructions + " >&2;} + { (exit 1); exit 1; }; } +fi + +# +# ------------------- Perl ---------------- +# +echo "$as_me:$LINENO: checking for Perl" >&5 +echo $ECHO_N "checking for Perl... $ECHO_C" >&6 + if ! binaryExists perl; then + { { echo "$as_me:$LINENO: error: + perl not found. + You need perl version 5.6.1 or later for CIL. + You can get perl at http://www.cpan.org/src/index.html . + " >&5 +echo "$as_me: error: + perl not found. + You need perl version 5.6.1 or later for CIL. + You can get perl at http://www.cpan.org/src/index.html . + " >&2;} + { (exit 1); exit 1; }; } + fi + + # sm: oh how nice it would be to just say "use English; + # print($PERL_VERSION)", but that appears broken on 5.6.1.. so I'm + # trying to say "caret right-bracket", but then that would run afoul + # of autoconf's quoting characters, so I use the "quadrigraph" ] + # to stand for right-bracket. what a mess. + perlver=`perl -e 'print($]);'` + if perl -e "exit( $perlver >= 5.006001 );"; then + { { echo "$as_me:$LINENO: error: + Found perl version $perlver, but at least 5.6.1 is required. + You can get a newer perl at http://www.cpan.org/src/index.html . + " >&5 +echo "$as_me: error: + Found perl version $perlver, but at least 5.6.1 is required. + You can get a newer perl at http://www.cpan.org/src/index.html . + " >&2;} + { (exit 1); exit 1; }; } + fi + + perlport=`perl -e "print $^O;"` + case "$perlport" in + cygwin) + ;; + MSWin32) # ActivePerl + ;; + linux) + ;; + freebsd) + ;; + openbsd) + ;; + darwin) # Mac OS X + ;; + solaris) + ;; + *) + { { echo "$as_me:$LINENO: error: + Unsupported Perl port $perlport -- sorry. + cygwin, MSWin32 (ActivePerl), linux, freebsd, openbsd, darwin, + and solaris are the supported ports. + " >&5 +echo "$as_me: error: + Unsupported Perl port $perlport -- sorry. + cygwin, MSWin32 (ActivePerl), linux, freebsd, openbsd, darwin, + and solaris are the supported ports. + " >&2;} + { (exit 1); exit 1; }; } + esac +echo "$as_me:$LINENO: result: found version $perlver, port $perlport" >&5 +echo "${ECHO_T}found version $perlver, port $perlport" >&6 + + # The cygwin port has some bugs in the File::Spec module +if test "$perlport" = "cygwin" ;then + echo "$as_me:$LINENO: checking for known cygwin Perl bug in File::Spec" >&5 +echo $ECHO_N "checking for known cygwin Perl bug in File::Spec... $ECHO_C" >&6 + perlfixres=`perl -e ' + use File::Spec; + if(File::Spec->file_name_is_absolute("C:/test")) { + print "no bug found"; exit 0; + } else { + print "bug"; + foreach $d (@INC) { + if(-f "$d/File/Spec/Unix.pm") { + open(IN, "<$d/File/Spec/Unix.pm"); + open(OUT, ">$d/File/Spec/Unix.pm.fixed") + || die "Cannot open $d/File/Spec/Unix.pm.fixed"; + while() { + if($_ =~ m|sub file_name_is_absolute|) { + print OUT $_; + print OUT scalar(); + print OUT <file_name_is_absolute("C:/test")) { + print "bug fixed"; exit 0; + } else { + print "cannot fix bug"; exit 1; + }'` + fi + if test "x$perlfixres" = "x" ;then + { { echo "$as_me:$LINENO: error: + Cannot run perl + " >&5 +echo "$as_me: error: + Cannot run perl + " >&2;} + { (exit 1); exit 1; }; } + elif test "$perlfixres" = "cannot fix bug" ;then + { { echo "$as_me:$LINENO: error: + Found a bug but cannot fix it. + " >&5 +echo "$as_me: error: + Found a bug but cannot fix it. + " >&2;} + { (exit 1); exit 1; }; } + else + echo "$as_me:$LINENO: result: $perlfixres" >&5 +echo "${ECHO_T}$perlfixres" >&6 + fi +fi + +# +# Now setup the performance counters +# +echo "$as_me:$LINENO: checking if performance counters are usable" >&5 +echo $ECHO_N "checking if performance counters are usable... $ECHO_C" >&6 +# Create a C file from src/perfcount.c.in +rm -f ./cycles.exe +if gcc -DCONFIGURATION_ONLY \ + -x c ocamlutil/perfcount.c.in -lm -o ./cycles.exe >/dev/null 2>&1; then + + if CYCLES_PER_USEC=`./cycles.exe 2>&1` ;then + echo "$as_me:$LINENO: result: ok ($CYCLES_PER_USEC cycles per us)" >&5 +echo "${ECHO_T}ok ($CYCLES_PER_USEC cycles per us)" >&6 + else + # Print what we got + echo "$as_me:$LINENO: result: no ($CYCLES_PER_USEC)" >&5 +echo "${ECHO_T}no ($CYCLES_PER_USEC)" >&6 + CYCLES_PER_USEC=0 + fi +else + CYCLES_PER_USEC=0 + echo "$as_me:$LINENO: result: no (cannot compile perfcount.c)" >&5 +echo "${ECHO_T}no (cannot compile perfcount.c)" >&6 +fi +rm -f ./cycles.exe + +# If we are on Linux and we use performance counters try to get +# the processor speed from /proc/cpuinfo +if test "$CYCLES_PER_USEC" != "0" ;then + case "$target" in + # linux + *86*linux*) + echo "$as_me:$LINENO: checking if /proc/cpuinfo has processor speed" >&5 +echo $ECHO_N "checking if /proc/cpuinfo has processor speed... $ECHO_C" >&6 + cpuinfo=`cat /proc/cpuinfo 2>/dev/null | grep "cpu MHz"` + procspeed=`echo $cpuinfo | sed 's/^.*[^0-9]\([0-9]\+\.[0-9]\+\).*$/\1/g'` + if test "$procspeed"!="" ;then + CYCLES_PER_USEC=$procspeed + echo "$as_me:$LINENO: result: got $CYCLES_PER_USEC cycles per us" >&5 +echo "${ECHO_T}got $CYCLES_PER_USEC cycles per us" >&6 + else + echo "$as_me:$LINENO: result: no" >&5 +echo "${ECHO_T}no" >&6 + fi + ;; + *) + ;; + esac + # Now set HAS_PERFCOUNT + HAS_PERFCOUNT=1 +else + HAS_PERFCOUNT=0 +fi + +# additional tools we might check for: +# - gnu make + +# +# -------------------- GCC -------------- +# + +echo "$as_me:$LINENO: checking for gcc version" >&5 +echo $ECHO_N "checking for gcc version... $ECHO_C" >&6 + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu +echo "$as_me:$LINENO: checking how to run the C preprocessor" >&5 +echo $ECHO_N "checking how to run the C preprocessor... $ECHO_C" >&6 +# On Suns, sometimes $CPP names a directory. +if test -n "$CPP" && test -d "$CPP"; then + CPP= +fi +if test -z "$CPP"; then + if test "${ac_cv_prog_CPP+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + # Double quotes because CPP needs to be expanded + for CPP in "$CC -E" "$CC -E -traditional-cpp" "/lib/cpp" + do + ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer to if __STDC__ is defined, since + # exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#ifdef __STDC__ +# include +#else +# include +#endif + Syntax error +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.$ac_ext + + # OK, works on sane cases. Now check whether non-existent headers + # can be detected and how. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + # Broken: success on invalid input. +continue +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.err conftest.$ac_ext +if $ac_preproc_ok; then + break +fi + + done + ac_cv_prog_CPP=$CPP + +fi + CPP=$ac_cv_prog_CPP +else + ac_cv_prog_CPP=$CPP +fi +echo "$as_me:$LINENO: result: $CPP" >&5 +echo "${ECHO_T}$CPP" >&6 +ac_preproc_ok=false +for ac_c_preproc_warn_flag in '' yes +do + # Use a header file that comes with gcc, so configuring glibc + # with a fresh cross-compiler works. + # Prefer to if __STDC__ is defined, since + # exists even on freestanding compilers. + # On the NeXT, cc -E runs the code through the compiler's parser, + # not just through cpp. "Syntax error" is here to catch this case. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#ifdef __STDC__ +# include +#else +# include +#endif + Syntax error +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + : +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + # Broken: fails on valid input. +continue +fi +rm -f conftest.err conftest.$ac_ext + + # OK, works on sane cases. Now check whether non-existent headers + # can be detected and how. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + # Broken: success on invalid input. +continue +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + # Passes both tests. +ac_preproc_ok=: +break +fi +rm -f conftest.err conftest.$ac_ext + +done +# Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +rm -f conftest.err conftest.$ac_ext +if $ac_preproc_ok; then + : +else + { { echo "$as_me:$LINENO: error: C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details." >&5 +echo "$as_me: error: C preprocessor \"$CPP\" fails sanity check +See \`config.log' for more details." >&2;} + { (exit 1); exit 1; }; } +fi + +ac_ext=c +ac_cpp='$CPP $CPPFLAGS' +ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5' +ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5' +ac_compiler_gnu=$ac_cv_c_compiler_gnu + + +echo "$as_me:$LINENO: checking for egrep" >&5 +echo $ECHO_N "checking for egrep... $ECHO_C" >&6 +if test "${ac_cv_prog_egrep+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if echo a | (grep -E '(a|b)') >/dev/null 2>&1 + then ac_cv_prog_egrep='grep -E' + else ac_cv_prog_egrep='egrep' + fi +fi +echo "$as_me:$LINENO: result: $ac_cv_prog_egrep" >&5 +echo "${ECHO_T}$ac_cv_prog_egrep" >&6 + EGREP=$ac_cv_prog_egrep + + +echo "$as_me:$LINENO: checking for ANSI C header files" >&5 +echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 +if test "${ac_cv_header_stdc+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +#include +#include +#include + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_header_stdc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_header_stdc=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "memchr" >/dev/null 2>&1; then + : +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "free" >/dev/null 2>&1; then + : +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. + if test "$cross_compiling" = yes; then + : +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +#if ((' ' & 0x0FF) == 0x020) +# define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#else +# define ISLOWER(c) \ + (('a' <= (c) && (c) <= 'i') \ + || ('j' <= (c) && (c) <= 'r') \ + || ('s' <= (c) && (c) <= 'z')) +# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) +#endif + +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int +main () +{ + int i; + for (i = 0; i < 256; i++) + if (XOR (islower (i), ISLOWER (i)) + || toupper (i) != TOUPPER (i)) + exit(2); + exit (0); +} +_ACEOF +rm -f conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + : +else + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +ac_cv_header_stdc=no +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi +fi +fi +echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 +echo "${ECHO_T}$ac_cv_header_stdc" >&6 +if test $ac_cv_header_stdc = yes; then + +cat >>confdefs.h <<\_ACEOF +#define STDC_HEADERS 1 +_ACEOF + +fi + +# On IRIX 5.3, sys/types and inttypes.h are conflicting. + + + + + + + + + +for ac_header in sys/types.h sys/stat.h stdlib.h string.h memory.h strings.h \ + inttypes.h stdint.h unistd.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default + +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_Header=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_Header=no" +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +echo "$as_me:$LINENO: checking for __builtin_va_list" >&5 +echo $ECHO_N "checking for __builtin_va_list... $ECHO_C" >&6 +if test "${ac_cv_type___builtin_va_list+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ +if ((__builtin_va_list *) 0) + return 0; +if (sizeof (__builtin_va_list)) + return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_type___builtin_va_list=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_type___builtin_va_list=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_type___builtin_va_list" >&5 +echo "${ECHO_T}$ac_cv_type___builtin_va_list" >&6 +if test $ac_cv_type___builtin_va_list = yes; then + HAVE_BUILTIN_VA_LIST=true +else + HAVE_BUILTIN_VA_LIST=false +fi + +echo "$as_me:$LINENO: checking if __thread is a keyword" >&5 +echo $ECHO_N "checking if __thread is a keyword... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +int main(int __thread) { return 0; } +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + THREAD_IS_KEYWORD=false +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +THREAD_IS_KEYWORD=true +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $THREAD_IS_KEYWORD" >&5 +echo "${ECHO_T}$THREAD_IS_KEYWORD" >&6 + +# Does gcc add underscores to identifiers to make assembly labels? +# (I think MSVC always does) +echo "$as_me:$LINENO: checking if gcc adds underscores to assembly labels." >&5 +echo $ECHO_N "checking if gcc adds underscores to assembly labels.... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +int main() { __asm__("jmp _main"); } +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + UNDERSCORE_NAME=true +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +UNDERSCORE_NAME=false +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +echo "$as_me:$LINENO: result: $UNDERSCORE_NAME" >&5 +echo "${ECHO_T}$UNDERSCORE_NAME" >&6 + + +# ----------- some stuff 'autoscan' put here -------------- +# (autoscan is part of the autoconf distribution) + +# checks for header files +echo "$as_me:$LINENO: checking for ANSI C header files" >&5 +echo $ECHO_N "checking for ANSI C header files... $ECHO_C" >&6 +if test "${ac_cv_header_stdc+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +#include +#include +#include + +int +main () +{ + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_header_stdc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_header_stdc=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext + +if test $ac_cv_header_stdc = yes; then + # SunOS 4.x string.h does not declare mem*, contrary to ANSI. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "memchr" >/dev/null 2>&1; then + : +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # ISC 2.0.2 stdlib.h does not declare free, contrary to ANSI. + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include + +_ACEOF +if (eval "$ac_cpp conftest.$ac_ext") 2>&5 | + $EGREP "free" >/dev/null 2>&1; then + : +else + ac_cv_header_stdc=no +fi +rm -f conftest* + +fi + +if test $ac_cv_header_stdc = yes; then + # /bin/cc in Irix-4.0.5 gets non-ANSI ctype macros unless using -ansi. + if test "$cross_compiling" = yes; then + : +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +#if ((' ' & 0x0FF) == 0x020) +# define ISLOWER(c) ('a' <= (c) && (c) <= 'z') +# define TOUPPER(c) (ISLOWER(c) ? 'A' + ((c) - 'a') : (c)) +#else +# define ISLOWER(c) \ + (('a' <= (c) && (c) <= 'i') \ + || ('j' <= (c) && (c) <= 'r') \ + || ('s' <= (c) && (c) <= 'z')) +# define TOUPPER(c) (ISLOWER(c) ? ((c) | 0x40) : (c)) +#endif + +#define XOR(e, f) (((e) && !(f)) || (!(e) && (f))) +int +main () +{ + int i; + for (i = 0; i < 256; i++) + if (XOR (islower (i), ISLOWER (i)) + || toupper (i) != TOUPPER (i)) + exit(2); + exit (0); +} +_ACEOF +rm -f conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + : +else + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +ac_cv_header_stdc=no +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi +fi +fi +echo "$as_me:$LINENO: result: $ac_cv_header_stdc" >&5 +echo "${ECHO_T}$ac_cv_header_stdc" >&6 +if test $ac_cv_header_stdc = yes; then + +cat >>confdefs.h <<\_ACEOF +#define STDC_HEADERS 1 +_ACEOF + +fi + + + + + + +for ac_header in stdlib.h strings.h sys/time.h unistd.h wchar.h +do +as_ac_Header=`echo "ac_cv_header_$ac_header" | $as_tr_sh` +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 +else + # Is the header compilable? +echo "$as_me:$LINENO: checking $ac_header usability" >&5 +echo $ECHO_N "checking $ac_header usability... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +#include <$ac_header> +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_header_compiler=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_header_compiler=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_compiler" >&5 +echo "${ECHO_T}$ac_header_compiler" >&6 + +# Is the header present? +echo "$as_me:$LINENO: checking $ac_header presence" >&5 +echo $ECHO_N "checking $ac_header presence... $ECHO_C" >&6 +cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include <$ac_header> +_ACEOF +if { (eval echo "$as_me:$LINENO: \"$ac_cpp conftest.$ac_ext\"") >&5 + (eval $ac_cpp conftest.$ac_ext) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } >/dev/null; then + if test -s conftest.err; then + ac_cpp_err=$ac_c_preproc_warn_flag + ac_cpp_err=$ac_cpp_err$ac_c_werror_flag + else + ac_cpp_err= + fi +else + ac_cpp_err=yes +fi +if test -z "$ac_cpp_err"; then + ac_header_preproc=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + + ac_header_preproc=no +fi +rm -f conftest.err conftest.$ac_ext +echo "$as_me:$LINENO: result: $ac_header_preproc" >&5 +echo "${ECHO_T}$ac_header_preproc" >&6 + +# So? What about this header? +case $ac_header_compiler:$ac_header_preproc:$ac_c_preproc_warn_flag in + yes:no: ) + { echo "$as_me:$LINENO: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&5 +echo "$as_me: WARNING: $ac_header: accepted by the compiler, rejected by the preprocessor!" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the compiler's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the compiler's result" >&2;} + ac_header_preproc=yes + ;; + no:yes:* ) + { echo "$as_me:$LINENO: WARNING: $ac_header: present but cannot be compiled" >&5 +echo "$as_me: WARNING: $ac_header: present but cannot be compiled" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: check for missing prerequisite headers?" >&5 +echo "$as_me: WARNING: $ac_header: check for missing prerequisite headers?" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: see the Autoconf documentation" >&5 +echo "$as_me: WARNING: $ac_header: see the Autoconf documentation" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&5 +echo "$as_me: WARNING: $ac_header: section \"Present But Cannot Be Compiled\"" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: proceeding with the preprocessor's result" >&5 +echo "$as_me: WARNING: $ac_header: proceeding with the preprocessor's result" >&2;} + { echo "$as_me:$LINENO: WARNING: $ac_header: in the future, the compiler will take precedence" >&5 +echo "$as_me: WARNING: $ac_header: in the future, the compiler will take precedence" >&2;} + ( + cat <<\_ASBOX +## ------------------------------------------ ## +## Report this to the AC_PACKAGE_NAME lists. ## +## ------------------------------------------ ## +_ASBOX + ) | + sed "s/^/$as_me: WARNING: /" >&2 + ;; +esac +echo "$as_me:$LINENO: checking for $ac_header" >&5 +echo $ECHO_N "checking for $ac_header... $ECHO_C" >&6 +if eval "test \"\${$as_ac_Header+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + eval "$as_ac_Header=\$ac_header_preproc" +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_Header'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_Header'}'`" >&6 + +fi +if test `eval echo '${'$as_ac_Header'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_header" | $as_tr_cpp` 1 +_ACEOF + +fi + +done + + +# checks for typedefs, structures, and compiler characteristics +echo "$as_me:$LINENO: checking for an ANSI C-conforming const" >&5 +echo $ECHO_N "checking for an ANSI C-conforming const... $ECHO_C" >&6 +if test "${ac_cv_c_const+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ + +int +main () +{ +/* FIXME: Include the comments suggested by Paul. */ +#ifndef __cplusplus + /* Ultrix mips cc rejects this. */ + typedef int charset[2]; + const charset x; + /* SunOS 4.1.1 cc rejects this. */ + char const *const *ccp; + char **p; + /* NEC SVR4.0.2 mips cc rejects this. */ + struct point {int x, y;}; + static struct point const zero = {0,0}; + /* AIX XL C 1.02.0.0 rejects this. + It does not let you subtract one const X* pointer from another in + an arm of an if-expression whose if-part is not a constant + expression */ + const char *g = "string"; + ccp = &g + (g ? g-g : 0); + /* HPUX 7.0 cc rejects these. */ + ++ccp; + p = (char**) ccp; + ccp = (char const *const *) p; + { /* SCO 3.2v4 cc rejects this. */ + char *t; + char const *s = 0 ? (char *) 0 : (char const *) 0; + + *t++ = 0; + } + { /* Someone thinks the Sun supposedly-ANSI compiler will reject this. */ + int x[] = {25, 17}; + const int *foo = &x[0]; + ++foo; + } + { /* Sun SC1.0 ANSI compiler rejects this -- but not the above. */ + typedef const int *iptr; + iptr p = 0; + ++p; + } + { /* AIX XL C 1.02.0.0 rejects this saying + "k.c", line 2.27: 1506-025 (S) Operand must be a modifiable lvalue. */ + struct s { int j; const int *ap[3]; }; + struct s *b; b->j = 5; + } + { /* ULTRIX-32 V3.1 (Rev 9) vcc rejects this */ + const int foo = 10; + } +#endif + + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_c_const=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_c_const=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_c_const" >&5 +echo "${ECHO_T}$ac_cv_c_const" >&6 +if test $ac_cv_c_const = no; then + +cat >>confdefs.h <<\_ACEOF +#define const +_ACEOF + +fi + +echo "$as_me:$LINENO: checking for inline" >&5 +echo $ECHO_N "checking for inline... $ECHO_C" >&6 +if test "${ac_cv_c_inline+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + ac_cv_c_inline=no +for ac_kw in inline __inline__ __inline; do + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#ifndef __cplusplus +typedef int foo_t; +static $ac_kw foo_t static_foo () {return 0; } +$ac_kw foo_t foo () {return 0; } +#endif + +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_c_inline=$ac_kw; break +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +done + +fi +echo "$as_me:$LINENO: result: $ac_cv_c_inline" >&5 +echo "${ECHO_T}$ac_cv_c_inline" >&6 + + +case $ac_cv_c_inline in + inline | yes) ;; + *) + case $ac_cv_c_inline in + no) ac_val=;; + *) ac_val=$ac_cv_c_inline;; + esac + cat >>confdefs.h <<_ACEOF +#ifndef __cplusplus +#define inline $ac_val +#endif +_ACEOF + ;; +esac + +echo "$as_me:$LINENO: checking whether time.h and sys/time.h may both be included" >&5 +echo $ECHO_N "checking whether time.h and sys/time.h may both be included... $ECHO_C" >&6 +if test "${ac_cv_header_time+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +#include +#include +#include + +int +main () +{ +if ((struct tm *) 0) +return 0; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext +if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5 + (eval $ac_compile) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest.$ac_objext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_header_time=yes +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +ac_cv_header_time=no +fi +rm -f conftest.err conftest.$ac_objext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: $ac_cv_header_time" >&5 +echo "${ECHO_T}$ac_cv_header_time" >&6 +if test $ac_cv_header_time = yes; then + +cat >>confdefs.h <<\_ACEOF +#define TIME_WITH_SYS_TIME 1 +_ACEOF + +fi + + +# checks for library functions; more autoscan stuff +echo "$as_me:$LINENO: checking for working memcmp" >&5 +echo $ECHO_N "checking for working memcmp... $ECHO_C" >&6 +if test "${ac_cv_func_memcmp_working+set}" = set; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + if test "$cross_compiling" = yes; then + ac_cv_func_memcmp_working=no +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +$ac_includes_default +int +main () +{ + + /* Some versions of memcmp are not 8-bit clean. */ + char c0 = 0x40, c1 = 0x80, c2 = 0x81; + if (memcmp(&c0, &c2, 1) >= 0 || memcmp(&c1, &c2, 1) >= 0) + exit (1); + + /* The Next x86 OpenStep bug shows up only when comparing 16 bytes + or more and with at least one buffer not starting on a 4-byte boundary. + William Lewis provided this test program. */ + { + char foo[21]; + char bar[21]; + int i; + for (i = 0; i < 4; i++) + { + char *a = foo + i; + char *b = bar + i; + strcpy (a, "--------01111111"); + strcpy (b, "--------10000000"); + if (memcmp (a, b, 16) >= 0) + exit (1); + } + exit (0); + } + + ; + return 0; +} +_ACEOF +rm -f conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + ac_cv_func_memcmp_working=yes +else + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +ac_cv_func_memcmp_working=no +fi +rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi +fi +echo "$as_me:$LINENO: result: $ac_cv_func_memcmp_working" >&5 +echo "${ECHO_T}$ac_cv_func_memcmp_working" >&6 +test $ac_cv_func_memcmp_working = no && case $LIBOBJS in + "memcmp.$ac_objext" | \ + *" memcmp.$ac_objext" | \ + "memcmp.$ac_objext "* | \ + *" memcmp.$ac_objext "* ) ;; + *) LIBOBJS="$LIBOBJS memcmp.$ac_objext" ;; +esac + + + + + + +for ac_func in mkdir select socket __sysv_signal +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + + + +# ----------- platform-specific code ------------- +# $target is typically processor-vendor-os +case "$target" in + # linux + *86*linux*|*86*freebsd*|*86*openbsd*|*86*darwin*) + echo "$as_me:$LINENO: result: configuring for linux/x86" >&5 +echo "${ECHO_T}configuring for linux/x86" >&6 + + ARCHOS=x86_LINUX + ;; + + # Mac OS X + *powerpc*darwin*) + echo "$as_me:$LINENO: result: configuring for powerpc/darwin" >&5 +echo "${ECHO_T}configuring for powerpc/darwin" >&6 + + ARCHOS=ppc_DARWIN + ;; + + # cygwin + *86*cygwin*) + echo "$as_me:$LINENO: result: configuring for Cygwin on win32/x86" >&5 +echo "${ECHO_T}configuring for Cygwin on win32/x86" >&6 + + ARCHOS=x86_WIN32 + + # override CILHOME; even on cygwin we want forward slashes + # sm: I folded this into what I hope will be the only + # case-analysis of machine type + CILHOME=`cygpath -wa "$CILHOME" | sed -e "s/\\\\\/\\//g"` + CC=`which $CC` + CC=`cygpath -wa "$CC" | sed -e "s/\\\\\/\\//g"` + ;; + + # Solaris + *sparc*solaris*) + echo "$as_me:$LINENO: result: configuring for SPARC/Solaris" >&5 +echo "${ECHO_T}configuring for SPARC/Solaris" >&6 + + ARCHOS=sparc_SOLARIS + ;; + + *) + { { echo "$as_me:$LINENO: error: + Unsupported platform $target -- sorry. + ./configure supports these platforms: + on x86: Linux, Win32(with Cygwin), freeBSD, openBSD, and Mac OS X + on PowerPC: Mac OS X + on SPARC: Solaris + " >&5 +echo "$as_me: error: + Unsupported platform $target -- sorry. + ./configure supports these platforms: + on x86: Linux, Win32(with Cygwin), freeBSD, openBSD, and Mac OS X + on PowerPC: Mac OS X + on SPARC: Solaris + " >&2;} + { (exit 1); exit 1; }; } + ;; +esac + +# Make the object directory if not already present +as_ac_File=`echo "ac_cv_file_obj/$ARCHOS" | $as_tr_sh` +echo "$as_me:$LINENO: checking for obj/$ARCHOS" >&5 +echo $ECHO_N "checking for obj/$ARCHOS... $ECHO_C" >&6 +if eval "test \"\${$as_ac_File+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + test "$cross_compiling" = yes && + { { echo "$as_me:$LINENO: error: cannot check for file existence when cross compiling" >&5 +echo "$as_me: error: cannot check for file existence when cross compiling" >&2;} + { (exit 1); exit 1; }; } +if test -r "obj/$ARCHOS"; then + eval "$as_ac_File=yes" +else + eval "$as_ac_File=no" +fi +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_File'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_File'}'`" >&6 +if test `eval echo '${'$as_ac_File'}'` = yes; then + : +else + echo "$as_me:$LINENO: result: creating obj/$ARCHOS" >&5 +echo "${ECHO_T}creating obj/$ARCHOS" >&6; + mkdir -p obj/$ARCHOS +fi + + +echo "$as_me:$LINENO: checking delete the obj/$ARCHOS/feature_config.ml and obj/$ARCHOS/machdep.ml file" >&5 +echo $ECHO_N "checking delete the obj/$ARCHOS/feature_config.ml and obj/$ARCHOS/machdep.ml file... $ECHO_C" >&6 +rm -f obj/$ARCHOS/machdep.ml +rm -f obj/.depend/machdep.d +rm -f obj/$ARCHOS/feature_config.ml +rm -f obj/.depend/feature_config.d +echo "$as_me:$LINENO: result: done" >&5 +echo "${ECHO_T}done" >&6 + +# We will use substitution variables whose definition contains newlines. The +# problem is that when config.status runs, it wants to break the series of +# substitution commands for sed into fragments based on line count. We could +# be unlucky and have config.status break the series of substitution in the +# middle of a variable that contains newlines. So, we first create a single +# variable called NEWLINE whose definition is a carriage return. This means +# that there will be exactly one opportunity for this error to happen (in the +# definition of NEWLINE). The occurrence of AC_SUBST for NEWLINE must occur +# after those of the variables that use it! And we want to put all of these +# very early on, to make sure that they are not around the place when the file +# bets broken. + +NEWLINE="\\ +" + + +# +# CIL/CCured features +# +# + +# Set the defaults + + +# Give a space-separated list of features with the defaults +features="blockinggraph=no rand=no arithabs=no zrapp=no" + + +# Check whether --with-blockinggraph or --without-blockinggraph was given. +if test "${with_blockinggraph+set}" = set; then + withval="$with_blockinggraph" + +fi; + +# Check whether --with-rand or --without-rand was given. +if test "${with_rand+set}" = set; then + withval="$with_rand" + +fi; + +# Check whether --with-arithabs or --without-arithabs was given. +if test "${with_arithabs+set}" = set; then + withval="$with_arithabs" + +fi; + +# Check whether --with-zrapp or --without-zrapp was given. +if test "${with_zrapp+set}" = set; then + withval="$with_zrapp" + +fi; + +# Smalloc.ml is distributed by {matth,nks}@cs.berkeley.edu as part of Scrash. +features="$features smalloc=no" + +# cqualann.ml is used by Matt Harren. Please ignore. +features="$features cqualann=no" + +# Now add any features specified in the command-line + +features="$features $EXTRAFEATURES" + +for f_val in $features +do + # If there is no =, then we default to yes + if ! (echo $f_val | grep "=" >/dev/null) ;then f_val="$f_val=yes"; fi + # echo "Testing feature $f_val" + f=`echo $f_val | sed -e s%=.*$%%` + echo "$as_me:$LINENO: checking whether to use CIL feature $f" >&5 +echo $ECHO_N "checking whether to use CIL feature $f... $ECHO_C" >&6 + # default value from "features" + defval=`echo $f_val | sed -e s%^.*=%%` + # current value + getcurval="echo \${with_$f:=$defval}" + curval=`eval $getcurval` + echo "$as_me:$LINENO: result: $curval" >&5 +echo "${ECHO_T}$curval" >&6 + if test $curval = yes ;then + CIL_FEATURES="$CIL_FEATURES $f" + fi +done + +## Now produce the CIL_FEATURES_DEFINES +CIL_FEATURES_DEFINES="" +# Convert to upper case +for f in `echo $CIL_FEATURES | tr a-z A-Z` +do + CIL_FEATURES_DEFINES="${CIL_FEATURES_DEFINES}@NEWLINE@export USE_$f=yes" +done + + +# ----------------- finish up ------------------- +# names of the variables that get substituted in files; for example, +# write @ARCHOS@ somewhere in a written file to get it substituted + + + + + + + + + + + + + + + + + +# finish the configure script and generate various files; ./configure +# will apply variable substitutions to .in to generate ; +# I find it useful to mark generated files as read-only so I don't +# accidentally edit them (and them lose my changes when ./configure +# runs again); I had originally done the chmod after AC_OUTPUT, but +# the problem is then the chmod doesn't run inside ./config.status + +# MY_AC_CONFIG_FILES(filename) +# do AC_CONFIG_FILES(filename, chmod a-w filename) + + + +{ + if test -f Makefile.in; then + ac_config_files="$ac_config_files Makefile" + + else + true + #echo "skipping [Makefile] because it's not in this distribution" + fi +} +{ + if test -f cil.spec.in; then + ac_config_files="$ac_config_files cil.spec" + + else + true + #echo "skipping [cil.spec] because it's not in this distribution" + fi +} +{ + if test -f config.mk.in; then + ac_config_files="$ac_config_files config.mk" + + else + true + #echo "skipping [config.mk] because it's not in this distribution" + fi +} +{ + if test -f test/Makefile.in; then + ac_config_files="$ac_config_files test/Makefile" + + else + true + #echo "skipping [test/Makefile] because it's not in this distribution" + fi +} +{ + if test -f bin/cilly.bat.in; then + ac_config_files="$ac_config_files bin/cilly.bat" + + else + true + #echo "skipping [bin/cilly.bat] because it's not in this distribution" + fi +} +{ + if test -f bin/patcher.bat.in; then + ac_config_files="$ac_config_files bin/patcher.bat" + + else + true + #echo "skipping [bin/patcher.bat] because it's not in this distribution" + fi +} +{ + if test -f bin/CilConfig.pm.in; then + ac_config_files="$ac_config_files bin/CilConfig.pm" + + else + true + #echo "skipping [bin/CilConfig.pm] because it's not in this distribution" + fi +} +{ + if test -f doc/index.html.in; then + ac_config_files="$ac_config_files doc/index.html" + + else + true + #echo "skipping [doc/index.html] because it's not in this distribution" + fi +} +{ + if test -f doc/header.html.in; then + ac_config_files="$ac_config_files doc/header.html" + + else + true + #echo "skipping [doc/header.html] because it's not in this distribution" + fi +} +{ + if test -f ocamlutil/perfcount.c.in; then + ac_config_files="$ac_config_files ocamlutil/perfcount.c" + + else + true + #echo "skipping [ocamlutil/perfcount.c] because it's not in this distribution" + fi +} + +cat >confcache <<\_ACEOF +# This file is a shell script that caches the results of configure +# tests run on this system so they can be shared between configure +# scripts and configure runs, see configure's option --config-cache. +# It is not useful on other systems. If it contains results you don't +# want to keep, you may remove or edit it. +# +# config.status only pays attention to the cache file if you give it +# the --recheck option to rerun configure. +# +# `ac_cv_env_foo' variables (set or unset) will be overridden when +# loading this file, other *unset* `ac_cv_foo' will be assigned the +# following values. + +_ACEOF + +# The following way of writing the cache mishandles newlines in values, +# but we know of no workaround that is simple, portable, and efficient. +# So, don't put newlines in cache variables' values. +# Ultrix sh set writes to stderr and can't be redirected directly, +# and sets the high bit in the cache file unless we assign to the vars. +{ + (set) 2>&1 | + case `(ac_space=' '; set | grep ac_space) 2>&1` in + *ac_space=\ *) + # `set' does not quote correctly, so add quotes (double-quote + # substitution turns \\\\ into \\, and sed turns \\ into \). + sed -n \ + "s/'/'\\\\''/g; + s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p" + ;; + *) + # `set' quotes correctly as required by POSIX, so do not add quotes. + sed -n \ + "s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1=\\2/p" + ;; + esac; +} | + sed ' + t clear + : clear + s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/ + t end + /^ac_cv_env/!s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/ + : end' >>confcache +if diff $cache_file confcache >/dev/null 2>&1; then :; else + if test -w $cache_file; then + test "x$cache_file" != "x/dev/null" && echo "updating cache $cache_file" + cat confcache >$cache_file + else + echo "not updating unwritable cache $cache_file" + fi +fi +rm -f confcache + +test "x$prefix" = xNONE && prefix=$ac_default_prefix +# Let make expand exec_prefix. +test "x$exec_prefix" = xNONE && exec_prefix='${prefix}' + +# VPATH may cause trouble with some makes, so we remove $(srcdir), +# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and +# trailing colons and then remove the whole line if VPATH becomes empty +# (actually we leave an empty line to preserve line numbers). +if test "x$srcdir" = x.; then + ac_vpsub='/^[ ]*VPATH[ ]*=/{ +s/:*\$(srcdir):*/:/; +s/:*\${srcdir}:*/:/; +s/:*@srcdir@:*/:/; +s/^\([^=]*=[ ]*\):*/\1/; +s/:*$//; +s/^[^=]*=[ ]*$//; +}' +fi + +DEFS=-DHAVE_CONFIG_H + +ac_libobjs= +ac_ltlibobjs= +for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_i=`echo "$ac_i" | + sed 's/\$U\././;s/\.o$//;s/\.obj$//'` + # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR + # will be set to the directory where LIBOBJS objects are built. + ac_libobjs="$ac_libobjs \${LIBOBJDIR}$ac_i\$U.$ac_objext" + ac_ltlibobjs="$ac_ltlibobjs \${LIBOBJDIR}$ac_i"'$U.lo' +done +LIBOBJS=$ac_libobjs + +LTLIBOBJS=$ac_ltlibobjs + + + +: ${CONFIG_STATUS=./config.status} +ac_clean_files_save=$ac_clean_files +ac_clean_files="$ac_clean_files $CONFIG_STATUS" +{ echo "$as_me:$LINENO: creating $CONFIG_STATUS" >&5 +echo "$as_me: creating $CONFIG_STATUS" >&6;} +cat >$CONFIG_STATUS <<_ACEOF +#! $SHELL +# Generated by $as_me. +# Run this file to recreate the current configuration. +# Compiler output produced by configure, useful for debugging +# configure, is in config.log if it exists. + +debug=false +ac_cs_recheck=false +ac_cs_silent=false +SHELL=\${CONFIG_SHELL-$SHELL} +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF +## --------------------- ## +## M4sh Initialization. ## +## --------------------- ## + +# Be Bourne compatible +if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then + emulate sh + NULLCMD=: + # Zsh 3.x and 4.x performs word splitting on ${1+"$@"}, which + # is contrary to our usage. Disable this feature. + alias -g '${1+"$@"}'='"$@"' +elif test -n "${BASH_VERSION+set}" && (set -o posix) >/dev/null 2>&1; then + set -o posix +fi +DUALCASE=1; export DUALCASE # for MKS sh + +# Support unset when possible. +if ( (MAIL=60; unset MAIL) || exit) >/dev/null 2>&1; then + as_unset=unset +else + as_unset=false +fi + + +# Work around bugs in pre-3.0 UWIN ksh. +$as_unset ENV MAIL MAILPATH +PS1='$ ' +PS2='> ' +PS4='+ ' + +# NLS nuisances. +for as_var in \ + LANG LANGUAGE LC_ADDRESS LC_ALL LC_COLLATE LC_CTYPE LC_IDENTIFICATION \ + LC_MEASUREMENT LC_MESSAGES LC_MONETARY LC_NAME LC_NUMERIC LC_PAPER \ + LC_TELEPHONE LC_TIME +do + if (set +x; test -z "`(eval $as_var=C; export $as_var) 2>&1`"); then + eval $as_var=C; export $as_var + else + $as_unset $as_var + fi +done + +# Required to use basename. +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi + +if (basename /) >/dev/null 2>&1 && test "X`basename / 2>&1`" = "X/"; then + as_basename=basename +else + as_basename=false +fi + + +# Name of the executable. +as_me=`$as_basename "$0" || +$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \ + X"$0" : 'X\(//\)$' \| \ + X"$0" : 'X\(/\)$' \| \ + . : '\(.\)' 2>/dev/null || +echo X/"$0" | + sed '/^.*\/\([^/][^/]*\)\/*$/{ s//\1/; q; } + /^X\/\(\/\/\)$/{ s//\1/; q; } + /^X\/\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + + +# PATH needs CR, and LINENO needs CR and PATH. +# Avoid depending upon Character Ranges. +as_cr_letters='abcdefghijklmnopqrstuvwxyz' +as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ' +as_cr_Letters=$as_cr_letters$as_cr_LETTERS +as_cr_digits='0123456789' +as_cr_alnum=$as_cr_Letters$as_cr_digits + +# The user is always right. +if test "${PATH_SEPARATOR+set}" != set; then + echo "#! /bin/sh" >conf$$.sh + echo "exit 0" >>conf$$.sh + chmod +x conf$$.sh + if (PATH="/nonexistent;."; conf$$.sh) >/dev/null 2>&1; then + PATH_SEPARATOR=';' + else + PATH_SEPARATOR=: + fi + rm -f conf$$.sh +fi + + + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" || { + # Find who we are. Look in the path if we contain no path at all + # relative or not. + case $0 in + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break +done + + ;; + esac + # We did not find ourselves, most probably we were run as `sh COMMAND' + # in which case we are not to be found in the path. + if test "x$as_myself" = x; then + as_myself=$0 + fi + if test ! -f "$as_myself"; then + { { echo "$as_me:$LINENO: error: cannot find myself; rerun with an absolute path" >&5 +echo "$as_me: error: cannot find myself; rerun with an absolute path" >&2;} + { (exit 1); exit 1; }; } + fi + case $CONFIG_SHELL in + '') + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for as_base in sh bash ksh sh5; do + case $as_dir in + /*) + if ("$as_dir/$as_base" -c ' + as_lineno_1=$LINENO + as_lineno_2=$LINENO + as_lineno_3=`(expr $as_lineno_1 + 1) 2>/dev/null` + test "x$as_lineno_1" != "x$as_lineno_2" && + test "x$as_lineno_3" = "x$as_lineno_2" ') 2>/dev/null; then + $as_unset BASH_ENV || test "${BASH_ENV+set}" != set || { BASH_ENV=; export BASH_ENV; } + $as_unset ENV || test "${ENV+set}" != set || { ENV=; export ENV; } + CONFIG_SHELL=$as_dir/$as_base + export CONFIG_SHELL + exec "$CONFIG_SHELL" "$0" ${1+"$@"} + fi;; + esac + done +done +;; + esac + + # Create $as_me.lineno as a copy of $as_myself, but with $LINENO + # uniformly replaced by the line number. The first 'sed' inserts a + # line-number line before each line; the second 'sed' does the real + # work. The second script uses 'N' to pair each line-number line + # with the numbered line, and appends trailing '-' during + # substitution so that $LINENO is not a special case at line end. + # (Raja R Harinath suggested sed '=', and Paul Eggert wrote the + # second 'sed' script. Blame Lee E. McMahon for sed's syntax. :-) + sed '=' <$as_myself | + sed ' + N + s,$,-, + : loop + s,^\(['$as_cr_digits']*\)\(.*\)[$]LINENO\([^'$as_cr_alnum'_]\),\1\2\1\3, + t loop + s,-$,, + s,^['$as_cr_digits']*\n,, + ' >$as_me.lineno && + chmod +x $as_me.lineno || + { { echo "$as_me:$LINENO: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&5 +echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2;} + { (exit 1); exit 1; }; } + + # Don't try to exec as it changes $[0], causing all sort of problems + # (the dirname of $[0] is not the place where we might find the + # original and so on. Autoconf is especially sensible to this). + . ./$as_me.lineno + # Exit status is that of the last command. + exit +} + + +case `echo "testing\c"; echo 1,2,3`,`echo -n testing; echo 1,2,3` in + *c*,-n*) ECHO_N= ECHO_C=' +' ECHO_T=' ' ;; + *c*,* ) ECHO_N=-n ECHO_C= ECHO_T= ;; + *) ECHO_N= ECHO_C='\c' ECHO_T= ;; +esac + +if expr a : '\(a\)' >/dev/null 2>&1; then + as_expr=expr +else + as_expr=false +fi + +rm -f conf$$ conf$$.exe conf$$.file +echo >conf$$.file +if ln -s conf$$.file conf$$ 2>/dev/null; then + # We could just check for DJGPP; but this test a) works b) is more generic + # and c) will remain valid once DJGPP supports symlinks (DJGPP 2.04). + if test -f conf$$.exe; then + # Don't use ln at all; we don't have any links + as_ln_s='cp -p' + else + as_ln_s='ln -s' + fi +elif ln conf$$.file conf$$ 2>/dev/null; then + as_ln_s=ln +else + as_ln_s='cp -p' +fi +rm -f conf$$ conf$$.exe conf$$.file + +if mkdir -p . 2>/dev/null; then + as_mkdir_p=: +else + test -d ./-p && rmdir ./-p + as_mkdir_p=false +fi + +as_executable_p="test -f" + +# Sed expression to map a string onto a valid CPP name. +as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'" + +# Sed expression to map a string onto a valid variable name. +as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'" + + +# IFS +# We need space, tab and new line, in precisely that order. +as_nl=' +' +IFS=" $as_nl" + +# CDPATH. +$as_unset CDPATH + +exec 6>&1 + +# Open the log real soon, to keep \$[0] and so on meaningful, and to +# report actual input values of CONFIG_FILES etc. instead of their +# values after options handling. Logging --version etc. is OK. +exec 5>>config.log +{ + echo + sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX +## Running $as_me. ## +_ASBOX +} >&5 +cat >&5 <<_CSEOF + +This file was extended by $as_me, which was +generated by GNU Autoconf 2.59. Invocation command line was + + CONFIG_FILES = $CONFIG_FILES + CONFIG_HEADERS = $CONFIG_HEADERS + CONFIG_LINKS = $CONFIG_LINKS + CONFIG_COMMANDS = $CONFIG_COMMANDS + $ $0 $@ + +_CSEOF +echo "on `(hostname || uname -n) 2>/dev/null | sed 1q`" >&5 +echo >&5 +_ACEOF + +# Files that config.status was made for. +if test -n "$ac_config_files"; then + echo "config_files=\"$ac_config_files\"" >>$CONFIG_STATUS +fi + +if test -n "$ac_config_headers"; then + echo "config_headers=\"$ac_config_headers\"" >>$CONFIG_STATUS +fi + +if test -n "$ac_config_links"; then + echo "config_links=\"$ac_config_links\"" >>$CONFIG_STATUS +fi + +if test -n "$ac_config_commands"; then + echo "config_commands=\"$ac_config_commands\"" >>$CONFIG_STATUS +fi + +cat >>$CONFIG_STATUS <<\_ACEOF + +ac_cs_usage="\ +\`$as_me' instantiates files from templates according to the +current configuration. + +Usage: $0 [OPTIONS] [FILE]... + + -h, --help print this help, then exit + -V, --version print version number, then exit + -q, --quiet do not print progress messages + -d, --debug don't remove temporary files + --recheck update $as_me by reconfiguring in the same conditions + --file=FILE[:TEMPLATE] + instantiate the configuration file FILE + --header=FILE[:TEMPLATE] + instantiate the configuration header FILE + +Configuration files: +$config_files + +Configuration headers: +$config_headers + +Report bugs to ." +_ACEOF + +cat >>$CONFIG_STATUS <<_ACEOF +ac_cs_version="\\ +config.status +configured by $0, generated by GNU Autoconf 2.59, + with options \\"`echo "$ac_configure_args" | sed 's/[\\""\`\$]/\\\\&/g'`\\" + +Copyright (C) 2003 Free Software Foundation, Inc. +This config.status script is free software; the Free Software Foundation +gives unlimited permission to copy, distribute and modify it." +srcdir=$srcdir +INSTALL="$INSTALL" +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF +# If no file are specified by the user, then we need to provide default +# value. By we need to know if files were specified by the user. +ac_need_defaults=: +while test $# != 0 +do + case $1 in + --*=*) + ac_option=`expr "x$1" : 'x\([^=]*\)='` + ac_optarg=`expr "x$1" : 'x[^=]*=\(.*\)'` + ac_shift=: + ;; + -*) + ac_option=$1 + ac_optarg=$2 + ac_shift=shift + ;; + *) # This is not an option, so the user has probably given explicit + # arguments. + ac_option=$1 + ac_need_defaults=false;; + esac + + case $ac_option in + # Handling of the options. +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF + -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r) + ac_cs_recheck=: ;; + --version | --vers* | -V ) + echo "$ac_cs_version"; exit 0 ;; + --he | --h) + # Conflict between --help and --header + { { echo "$as_me:$LINENO: error: ambiguous option: $1 +Try \`$0 --help' for more information." >&5 +echo "$as_me: error: ambiguous option: $1 +Try \`$0 --help' for more information." >&2;} + { (exit 1); exit 1; }; };; + --help | --hel | -h ) + echo "$ac_cs_usage"; exit 0 ;; + --debug | --d* | -d ) + debug=: ;; + --file | --fil | --fi | --f ) + $ac_shift + CONFIG_FILES="$CONFIG_FILES $ac_optarg" + ac_need_defaults=false;; + --header | --heade | --head | --hea ) + $ac_shift + CONFIG_HEADERS="$CONFIG_HEADERS $ac_optarg" + ac_need_defaults=false;; + -q | -quiet | --quiet | --quie | --qui | --qu | --q \ + | -silent | --silent | --silen | --sile | --sil | --si | --s) + ac_cs_silent=: ;; + + # This is an error. + -*) { { echo "$as_me:$LINENO: error: unrecognized option: $1 +Try \`$0 --help' for more information." >&5 +echo "$as_me: error: unrecognized option: $1 +Try \`$0 --help' for more information." >&2;} + { (exit 1); exit 1; }; } ;; + + *) ac_config_targets="$ac_config_targets $1" ;; + + esac + shift +done + +ac_configure_extra_args= + +if $ac_cs_silent; then + exec 6>/dev/null + ac_configure_extra_args="$ac_configure_extra_args --silent" +fi + +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF +if \$ac_cs_recheck; then + echo "running $SHELL $0 " $ac_configure_args \$ac_configure_extra_args " --no-create --no-recursion" >&6 + exec $SHELL $0 $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion +fi + +_ACEOF + + + + + +cat >>$CONFIG_STATUS <<\_ACEOF +for ac_config_target in $ac_config_targets +do + case "$ac_config_target" in + # Handling of arguments. + "Makefile" ) CONFIG_FILES="$CONFIG_FILES Makefile" ;; + "cil.spec" ) CONFIG_FILES="$CONFIG_FILES cil.spec" ;; + "config.mk" ) CONFIG_FILES="$CONFIG_FILES config.mk" ;; + "test/Makefile" ) CONFIG_FILES="$CONFIG_FILES test/Makefile" ;; + "bin/cilly.bat" ) CONFIG_FILES="$CONFIG_FILES bin/cilly.bat" ;; + "bin/patcher.bat" ) CONFIG_FILES="$CONFIG_FILES bin/patcher.bat" ;; + "bin/CilConfig.pm" ) CONFIG_FILES="$CONFIG_FILES bin/CilConfig.pm" ;; + "doc/index.html" ) CONFIG_FILES="$CONFIG_FILES doc/index.html" ;; + "doc/header.html" ) CONFIG_FILES="$CONFIG_FILES doc/header.html" ;; + "ocamlutil/perfcount.c" ) CONFIG_FILES="$CONFIG_FILES ocamlutil/perfcount.c" ;; + "config.h" ) CONFIG_HEADERS="$CONFIG_HEADERS config.h" ;; + *) { { echo "$as_me:$LINENO: error: invalid argument: $ac_config_target" >&5 +echo "$as_me: error: invalid argument: $ac_config_target" >&2;} + { (exit 1); exit 1; }; };; + esac +done + +# If the user did not use the arguments to specify the items to instantiate, +# then the envvar interface is used. Set only those that are not. +# We use the long form for the default assignment because of an extremely +# bizarre bug on SunOS 4.1.3. +if $ac_need_defaults; then + test "${CONFIG_FILES+set}" = set || CONFIG_FILES=$config_files + test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers +fi + +# Have a temporary directory for convenience. Make it in the build tree +# simply because there is no reason to put it here, and in addition, +# creating and moving files from /tmp can sometimes cause problems. +# Create a temporary directory, and hook for its removal unless debugging. +$debug || +{ + trap 'exit_status=$?; rm -rf $tmp && exit $exit_status' 0 + trap '{ (exit 1); exit 1; }' 1 2 13 15 +} + +# Create a (secure) tmp directory for tmp files. + +{ + tmp=`(umask 077 && mktemp -d -q "./confstatXXXXXX") 2>/dev/null` && + test -n "$tmp" && test -d "$tmp" +} || +{ + tmp=./confstat$$-$RANDOM + (umask 077 && mkdir $tmp) +} || +{ + echo "$me: cannot create a temporary directory in ." >&2 + { (exit 1); exit 1; } +} + +_ACEOF + +cat >>$CONFIG_STATUS <<_ACEOF + +# +# CONFIG_FILES section. +# + +# No need to generate the scripts if there are no CONFIG_FILES. +# This happens for instance when ./config.status config.h +if test -n "\$CONFIG_FILES"; then + # Protect against being on the right side of a sed subst in config.status. + sed 's/,@/@@/; s/@,/@@/; s/,;t t\$/@;t t/; /@;t t\$/s/[\\\\&,]/\\\\&/g; + s/@@/,@/; s/@@/@,/; s/@;t t\$/,;t t/' >\$tmp/subs.sed <<\\CEOF +s,@CIL_FEATURES_DEFINES@,$CIL_FEATURES_DEFINES,;t t +s,@NEWLINE@,$NEWLINE,;t t +s,@SHELL@,$SHELL,;t t +s,@PATH_SEPARATOR@,$PATH_SEPARATOR,;t t +s,@PACKAGE_NAME@,$PACKAGE_NAME,;t t +s,@PACKAGE_TARNAME@,$PACKAGE_TARNAME,;t t +s,@PACKAGE_VERSION@,$PACKAGE_VERSION,;t t +s,@PACKAGE_STRING@,$PACKAGE_STRING,;t t +s,@PACKAGE_BUGREPORT@,$PACKAGE_BUGREPORT,;t t +s,@exec_prefix@,$exec_prefix,;t t +s,@prefix@,$prefix,;t t +s,@program_transform_name@,$program_transform_name,;t t +s,@bindir@,$bindir,;t t +s,@sbindir@,$sbindir,;t t +s,@libexecdir@,$libexecdir,;t t +s,@datadir@,$datadir,;t t +s,@sysconfdir@,$sysconfdir,;t t +s,@sharedstatedir@,$sharedstatedir,;t t +s,@localstatedir@,$localstatedir,;t t +s,@libdir@,$libdir,;t t +s,@includedir@,$includedir,;t t +s,@oldincludedir@,$oldincludedir,;t t +s,@infodir@,$infodir,;t t +s,@mandir@,$mandir,;t t +s,@build_alias@,$build_alias,;t t +s,@host_alias@,$host_alias,;t t +s,@target_alias@,$target_alias,;t t +s,@DEFS@,$DEFS,;t t +s,@ECHO_C@,$ECHO_C,;t t +s,@ECHO_N@,$ECHO_N,;t t +s,@ECHO_T@,$ECHO_T,;t t +s,@LIBS@,$LIBS,;t t +s,@CC@,$CC,;t t +s,@CFLAGS@,$CFLAGS,;t t +s,@LDFLAGS@,$LDFLAGS,;t t +s,@CPPFLAGS@,$CPPFLAGS,;t t +s,@ac_ct_CC@,$ac_ct_CC,;t t +s,@EXEEXT@,$EXEEXT,;t t +s,@OBJEXT@,$OBJEXT,;t t +s,@INSTALL_PROGRAM@,$INSTALL_PROGRAM,;t t +s,@INSTALL_SCRIPT@,$INSTALL_SCRIPT,;t t +s,@INSTALL_DATA@,$INSTALL_DATA,;t t +s,@build@,$build,;t t +s,@build_cpu@,$build_cpu,;t t +s,@build_vendor@,$build_vendor,;t t +s,@build_os@,$build_os,;t t +s,@host@,$host,;t t +s,@host_cpu@,$host_cpu,;t t +s,@host_vendor@,$host_vendor,;t t +s,@host_os@,$host_os,;t t +s,@target@,$target,;t t +s,@target_cpu@,$target_cpu,;t t +s,@target_vendor@,$target_vendor,;t t +s,@target_os@,$target_os,;t t +s,@CPP@,$CPP,;t t +s,@EGREP@,$EGREP,;t t +s,@LIBOBJS@,$LIBOBJS,;t t +s,@ARCHOS@,$ARCHOS,;t t +s,@CILHOME@,$CILHOME,;t t +s,@HAS_MSVC@,$HAS_MSVC,;t t +s,@DEFAULT_COMPILER@,$DEFAULT_COMPILER,;t t +s,@DEFAULT_CIL_MODE@,$DEFAULT_CIL_MODE,;t t +s,@CIL_VERSION_MAJOR@,$CIL_VERSION_MAJOR,;t t +s,@CIL_VERSION_MINOR@,$CIL_VERSION_MINOR,;t t +s,@CIL_VERSION_REV@,$CIL_VERSION_REV,;t t +s,@CIL_VERSION@,$CIL_VERSION,;t t +s,@CYCLES_PER_USEC@,$CYCLES_PER_USEC,;t t +s,@HAS_PERFCOUNT@,$HAS_PERFCOUNT,;t t +s,@HAVE_BUILTIN_VA_LIST@,$HAVE_BUILTIN_VA_LIST,;t t +s,@THREAD_IS_KEYWORD@,$THREAD_IS_KEYWORD,;t t +s,@UNDERSCORE_NAME@,$UNDERSCORE_NAME,;t t +s,@EXTRAFEATURES@,$EXTRAFEATURES,;t t +s,@EXTRASRCDIRS@,$EXTRASRCDIRS,;t t +s,@LTLIBOBJS@,$LTLIBOBJS,;t t +CEOF + +_ACEOF + + cat >>$CONFIG_STATUS <<\_ACEOF + # Split the substitutions into bite-sized pieces for seds with + # small command number limits, like on Digital OSF/1 and HP-UX. + ac_max_sed_lines=48 + ac_sed_frag=1 # Number of current file. + ac_beg=1 # First line for current file. + ac_end=$ac_max_sed_lines # Line after last line for current file. + ac_more_lines=: + ac_sed_cmds= + while $ac_more_lines; do + if test $ac_beg -gt 1; then + sed "1,${ac_beg}d; ${ac_end}q" $tmp/subs.sed >$tmp/subs.frag + else + sed "${ac_end}q" $tmp/subs.sed >$tmp/subs.frag + fi + if test ! -s $tmp/subs.frag; then + ac_more_lines=false + else + # The purpose of the label and of the branching condition is to + # speed up the sed processing (if there are no `@' at all, there + # is no need to browse any of the substitutions). + # These are the two extra sed commands mentioned above. + (echo ':t + /@[a-zA-Z_][a-zA-Z_0-9]*@/!b' && cat $tmp/subs.frag) >$tmp/subs-$ac_sed_frag.sed + if test -z "$ac_sed_cmds"; then + ac_sed_cmds="sed -f $tmp/subs-$ac_sed_frag.sed" + else + ac_sed_cmds="$ac_sed_cmds | sed -f $tmp/subs-$ac_sed_frag.sed" + fi + ac_sed_frag=`expr $ac_sed_frag + 1` + ac_beg=$ac_end + ac_end=`expr $ac_end + $ac_max_sed_lines` + fi + done + if test -z "$ac_sed_cmds"; then + ac_sed_cmds=cat + fi +fi # test -n "$CONFIG_FILES" + +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF +for ac_file in : $CONFIG_FILES; do test "x$ac_file" = x: && continue + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case $ac_file in + - | *:- | *:-:* ) # input from stdin + cat >$tmp/stdin + ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + * ) ac_file_in=$ac_file.in ;; + esac + + # Compute @srcdir@, @top_srcdir@, and @INSTALL@ for subdirectories. + ac_dir=`(dirname "$ac_file") 2>/dev/null || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + { if $as_mkdir_p; then + mkdir -p "$ac_dir" + else + as_dir="$ac_dir" + as_dirs= + while test ! -d "$as_dir"; do + as_dirs="$as_dir $as_dirs" + as_dir=`(dirname "$as_dir") 2>/dev/null || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + done + test ! -n "$as_dirs" || mkdir $as_dirs + fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 +echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} + { (exit 1); exit 1; }; }; } + + ac_builddir=. + +if test "$ac_dir" != .; then + ac_dir_suffix=/`echo "$ac_dir" | sed 's,^\.[\\/],,'` + # A "../" for each directory in $ac_dir_suffix. + ac_top_builddir=`echo "$ac_dir_suffix" | sed 's,/[^\\/]*,../,g'` +else + ac_dir_suffix= ac_top_builddir= +fi + +case $srcdir in + .) # No --srcdir option. We are building in place. + ac_srcdir=. + if test -z "$ac_top_builddir"; then + ac_top_srcdir=. + else + ac_top_srcdir=`echo $ac_top_builddir | sed 's,/$,,'` + fi ;; + [\\/]* | ?:[\\/]* ) # Absolute path. + ac_srcdir=$srcdir$ac_dir_suffix; + ac_top_srcdir=$srcdir ;; + *) # Relative path. + ac_srcdir=$ac_top_builddir$srcdir$ac_dir_suffix + ac_top_srcdir=$ac_top_builddir$srcdir ;; +esac + +# Do not use `cd foo && pwd` to compute absolute paths, because +# the directories may not exist. +case `pwd` in +.) ac_abs_builddir="$ac_dir";; +*) + case "$ac_dir" in + .) ac_abs_builddir=`pwd`;; + [\\/]* | ?:[\\/]* ) ac_abs_builddir="$ac_dir";; + *) ac_abs_builddir=`pwd`/"$ac_dir";; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_builddir=${ac_top_builddir}.;; +*) + case ${ac_top_builddir}. in + .) ac_abs_top_builddir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_builddir=${ac_top_builddir}.;; + *) ac_abs_top_builddir=$ac_abs_builddir/${ac_top_builddir}.;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_srcdir=$ac_srcdir;; +*) + case $ac_srcdir in + .) ac_abs_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_srcdir=$ac_srcdir;; + *) ac_abs_srcdir=$ac_abs_builddir/$ac_srcdir;; + esac;; +esac +case $ac_abs_builddir in +.) ac_abs_top_srcdir=$ac_top_srcdir;; +*) + case $ac_top_srcdir in + .) ac_abs_top_srcdir=$ac_abs_builddir;; + [\\/]* | ?:[\\/]* ) ac_abs_top_srcdir=$ac_top_srcdir;; + *) ac_abs_top_srcdir=$ac_abs_builddir/$ac_top_srcdir;; + esac;; +esac + + + case $INSTALL in + [\\/$]* | ?:[\\/]* ) ac_INSTALL=$INSTALL ;; + *) ac_INSTALL=$ac_top_builddir$INSTALL ;; + esac + + if test x"$ac_file" != x-; then + { echo "$as_me:$LINENO: creating $ac_file" >&5 +echo "$as_me: creating $ac_file" >&6;} + rm -f "$ac_file" + fi + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + if test x"$ac_file" = x-; then + configure_input= + else + configure_input="$ac_file. " + fi + configure_input=$configure_input"Generated from `echo $ac_file_in | + sed 's,.*/,,'` by configure." + + # First look for the input files in the build tree, otherwise in the + # src tree. + ac_file_inputs=`IFS=: + for f in $ac_file_in; do + case $f in + -) echo $tmp/stdin ;; + [\\/$]*) + # Absolute (can't be DOS-style, as IFS=:) + test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + echo "$f";; + *) # Relative + if test -f "$f"; then + # Build tree + echo "$f" + elif test -f "$srcdir/$f"; then + # Source tree + echo "$srcdir/$f" + else + # /dev/null tree + { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + fi;; + esac + done` || { (exit 1); exit 1; } +_ACEOF +cat >>$CONFIG_STATUS <<_ACEOF + sed "$ac_vpsub +$extrasub +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF +:t +/@[a-zA-Z_][a-zA-Z_0-9]*@/!b +s,@configure_input@,$configure_input,;t t +s,@srcdir@,$ac_srcdir,;t t +s,@abs_srcdir@,$ac_abs_srcdir,;t t +s,@top_srcdir@,$ac_top_srcdir,;t t +s,@abs_top_srcdir@,$ac_abs_top_srcdir,;t t +s,@builddir@,$ac_builddir,;t t +s,@abs_builddir@,$ac_abs_builddir,;t t +s,@top_builddir@,$ac_top_builddir,;t t +s,@abs_top_builddir@,$ac_abs_top_builddir,;t t +s,@INSTALL@,$ac_INSTALL,;t t +" $ac_file_inputs | (eval "$ac_sed_cmds") >$tmp/out + rm -f $tmp/stdin + if test x"$ac_file" != x-; then + mv $tmp/out $ac_file + else + cat $tmp/out + rm -f $tmp/out + fi + + # Run the commands associated with the file. + case $ac_file in + Makefile ) chmod a-w Makefile ;; + cil.spec ) chmod a-w cil.spec ;; + config.mk ) chmod a-w config.mk ;; + test/Makefile ) chmod a-w test/Makefile ;; + bin/cilly.bat ) chmod a-w,a+x bin/cilly.bat ;; + bin/patcher.bat ) chmod a-w,a+x bin/patcher.bat ;; + bin/CilConfig.pm ) chmod a-w bin/CilConfig.pm ;; + doc/index.html ) chmod a-w doc/index.html ;; + doc/header.html ) chmod a-w doc/header.html ;; + ocamlutil/perfcount.c ) chmod a-w ocamlutil/perfcount.c ;; + esac +done +_ACEOF +cat >>$CONFIG_STATUS <<\_ACEOF + +# +# CONFIG_HEADER section. +# + +# These sed commands are passed to sed as "A NAME B NAME C VALUE D", where +# NAME is the cpp macro being defined and VALUE is the value it is being given. +# +# ac_d sets the value in "#define NAME VALUE" lines. +ac_dA='s,^\([ ]*\)#\([ ]*define[ ][ ]*\)' +ac_dB='[ ].*$,\1#\2' +ac_dC=' ' +ac_dD=',;t' +# ac_u turns "#undef NAME" without trailing blanks into "#define NAME VALUE". +ac_uA='s,^\([ ]*\)#\([ ]*\)undef\([ ][ ]*\)' +ac_uB='$,\1#\2define\3' +ac_uC=' ' +ac_uD=',;t' + +for ac_file in : $CONFIG_HEADERS; do test "x$ac_file" = x: && continue + # Support "outfile[:infile[:infile...]]", defaulting infile="outfile.in". + case $ac_file in + - | *:- | *:-:* ) # input from stdin + cat >$tmp/stdin + ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + *:* ) ac_file_in=`echo "$ac_file" | sed 's,[^:]*:,,'` + ac_file=`echo "$ac_file" | sed 's,:.*,,'` ;; + * ) ac_file_in=$ac_file.in ;; + esac + + test x"$ac_file" != x- && { echo "$as_me:$LINENO: creating $ac_file" >&5 +echo "$as_me: creating $ac_file" >&6;} + + # First look for the input files in the build tree, otherwise in the + # src tree. + ac_file_inputs=`IFS=: + for f in $ac_file_in; do + case $f in + -) echo $tmp/stdin ;; + [\\/$]*) + # Absolute (can't be DOS-style, as IFS=:) + test -f "$f" || { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + # Do quote $f, to prevent DOS paths from being IFS'd. + echo "$f";; + *) # Relative + if test -f "$f"; then + # Build tree + echo "$f" + elif test -f "$srcdir/$f"; then + # Source tree + echo "$srcdir/$f" + else + # /dev/null tree + { { echo "$as_me:$LINENO: error: cannot find input file: $f" >&5 +echo "$as_me: error: cannot find input file: $f" >&2;} + { (exit 1); exit 1; }; } + fi;; + esac + done` || { (exit 1); exit 1; } + # Remove the trailing spaces. + sed 's/[ ]*$//' $ac_file_inputs >$tmp/in + +_ACEOF + +# Transform confdefs.h into two sed scripts, `conftest.defines' and +# `conftest.undefs', that substitutes the proper values into +# config.h.in to produce config.h. The first handles `#define' +# templates, and the second `#undef' templates. +# And first: Protect against being on the right side of a sed subst in +# config.status. Protect against being in an unquoted here document +# in config.status. +rm -f conftest.defines conftest.undefs +# Using a here document instead of a string reduces the quoting nightmare. +# Putting comments in sed scripts is not portable. +# +# `end' is used to avoid that the second main sed command (meant for +# 0-ary CPP macros) applies to n-ary macro definitions. +# See the Autoconf documentation for `clear'. +cat >confdef2sed.sed <<\_ACEOF +s/[\\&,]/\\&/g +s,[\\$`],\\&,g +t clear +: clear +s,^[ ]*#[ ]*define[ ][ ]*\([^ (][^ (]*\)\(([^)]*)\)[ ]*\(.*\)$,${ac_dA}\1${ac_dB}\1\2${ac_dC}\3${ac_dD},gp +t end +s,^[ ]*#[ ]*define[ ][ ]*\([^ ][^ ]*\)[ ]*\(.*\)$,${ac_dA}\1${ac_dB}\1${ac_dC}\2${ac_dD},gp +: end +_ACEOF +# If some macros were called several times there might be several times +# the same #defines, which is useless. Nevertheless, we may not want to +# sort them, since we want the *last* AC-DEFINE to be honored. +uniq confdefs.h | sed -n -f confdef2sed.sed >conftest.defines +sed 's/ac_d/ac_u/g' conftest.defines >conftest.undefs +rm -f confdef2sed.sed + +# This sed command replaces #undef with comments. This is necessary, for +# example, in the case of _POSIX_SOURCE, which is predefined and required +# on some systems where configure will not decide to define it. +cat >>conftest.undefs <<\_ACEOF +s,^[ ]*#[ ]*undef[ ][ ]*[a-zA-Z_][a-zA-Z_0-9]*,/* & */, +_ACEOF + +# Break up conftest.defines because some shells have a limit on the size +# of here documents, and old seds have small limits too (100 cmds). +echo ' # Handle all the #define templates only if necessary.' >>$CONFIG_STATUS +echo ' if grep "^[ ]*#[ ]*define" $tmp/in >/dev/null; then' >>$CONFIG_STATUS +echo ' # If there are no defines, we may have an empty if/fi' >>$CONFIG_STATUS +echo ' :' >>$CONFIG_STATUS +rm -f conftest.tail +while grep . conftest.defines >/dev/null +do + # Write a limited-size here document to $tmp/defines.sed. + echo ' cat >$tmp/defines.sed <>$CONFIG_STATUS + # Speed up: don't consider the non `#define' lines. + echo '/^[ ]*#[ ]*define/!b' >>$CONFIG_STATUS + # Work around the forget-to-reset-the-flag bug. + echo 't clr' >>$CONFIG_STATUS + echo ': clr' >>$CONFIG_STATUS + sed ${ac_max_here_lines}q conftest.defines >>$CONFIG_STATUS + echo 'CEOF + sed -f $tmp/defines.sed $tmp/in >$tmp/out + rm -f $tmp/in + mv $tmp/out $tmp/in +' >>$CONFIG_STATUS + sed 1,${ac_max_here_lines}d conftest.defines >conftest.tail + rm -f conftest.defines + mv conftest.tail conftest.defines +done +rm -f conftest.defines +echo ' fi # grep' >>$CONFIG_STATUS +echo >>$CONFIG_STATUS + +# Break up conftest.undefs because some shells have a limit on the size +# of here documents, and old seds have small limits too (100 cmds). +echo ' # Handle all the #undef templates' >>$CONFIG_STATUS +rm -f conftest.tail +while grep . conftest.undefs >/dev/null +do + # Write a limited-size here document to $tmp/undefs.sed. + echo ' cat >$tmp/undefs.sed <>$CONFIG_STATUS + # Speed up: don't consider the non `#undef' + echo '/^[ ]*#[ ]*undef/!b' >>$CONFIG_STATUS + # Work around the forget-to-reset-the-flag bug. + echo 't clr' >>$CONFIG_STATUS + echo ': clr' >>$CONFIG_STATUS + sed ${ac_max_here_lines}q conftest.undefs >>$CONFIG_STATUS + echo 'CEOF + sed -f $tmp/undefs.sed $tmp/in >$tmp/out + rm -f $tmp/in + mv $tmp/out $tmp/in +' >>$CONFIG_STATUS + sed 1,${ac_max_here_lines}d conftest.undefs >conftest.tail + rm -f conftest.undefs + mv conftest.tail conftest.undefs +done +rm -f conftest.undefs + +cat >>$CONFIG_STATUS <<\_ACEOF + # Let's still pretend it is `configure' which instantiates (i.e., don't + # use $as_me), people would be surprised to read: + # /* config.h. Generated by config.status. */ + if test x"$ac_file" = x-; then + echo "/* Generated by configure. */" >$tmp/config.h + else + echo "/* $ac_file. Generated by configure. */" >$tmp/config.h + fi + cat $tmp/in >>$tmp/config.h + rm -f $tmp/in + if test x"$ac_file" != x-; then + if diff $ac_file $tmp/config.h >/dev/null 2>&1; then + { echo "$as_me:$LINENO: $ac_file is unchanged" >&5 +echo "$as_me: $ac_file is unchanged" >&6;} + else + ac_dir=`(dirname "$ac_file") 2>/dev/null || +$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$ac_file" : 'X\(//\)[^/]' \| \ + X"$ac_file" : 'X\(//\)$' \| \ + X"$ac_file" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$ac_file" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + { if $as_mkdir_p; then + mkdir -p "$ac_dir" + else + as_dir="$ac_dir" + as_dirs= + while test ! -d "$as_dir"; do + as_dirs="$as_dir $as_dirs" + as_dir=`(dirname "$as_dir") 2>/dev/null || +$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \ + X"$as_dir" : 'X\(//\)[^/]' \| \ + X"$as_dir" : 'X\(//\)$' \| \ + X"$as_dir" : 'X\(/\)' \| \ + . : '\(.\)' 2>/dev/null || +echo X"$as_dir" | + sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{ s//\1/; q; } + /^X\(\/\/\)[^/].*/{ s//\1/; q; } + /^X\(\/\/\)$/{ s//\1/; q; } + /^X\(\/\).*/{ s//\1/; q; } + s/.*/./; q'` + done + test ! -n "$as_dirs" || mkdir $as_dirs + fi || { { echo "$as_me:$LINENO: error: cannot create directory \"$ac_dir\"" >&5 +echo "$as_me: error: cannot create directory \"$ac_dir\"" >&2;} + { (exit 1); exit 1; }; }; } + + rm -f $ac_file + mv $tmp/config.h $ac_file + fi + else + cat $tmp/config.h + rm -f $tmp/config.h + fi +done +_ACEOF + +cat >>$CONFIG_STATUS <<\_ACEOF + +{ (exit 0); exit 0; } +_ACEOF +chmod +x $CONFIG_STATUS +ac_clean_files=$ac_clean_files_save + + +# configure is writing to config.log, and then calls config.status. +# config.status does its own redirection, appending to config.log. +# Unfortunately, on DOS this fails, as config.log is still kept open +# by configure, so config.status won't be able to write to it; its +# output is simply discarded. So we exec the FD to /dev/null, +# effectively closing config.log, so it can be properly (re)opened and +# appended to by config.status. When coming back to configure, we +# need to make the FD available again. +if test "$no_create" != yes; then + ac_cs_success=: + ac_config_status_args= + test "$silent" = yes && + ac_config_status_args="$ac_config_status_args --quiet" + exec 5>/dev/null + $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. + $ac_cs_success || { (exit 1); exit 1; } +fi + + +# show the user what the variables have been set to +cat </dev/null 2>&1; then + return 0 + else + return 1 + fi +} + + +# -------------- portable configuration ---------------- +# this specifies the root of the source tree; it's just the +# directory where ./configure runs, except on cygwin, which +# overrides this below +CILHOME=`pwd` + +DEFAULT_COMPILER=_GNUCC +DEFAULT_CIL_MODE=GNUCC + +# is the microsoft compiler available? +# hmm.. I think we should check the version or something, because +# sometimes people have Common Lisp's interpreter called 'cl' .. +AC_MSG_CHECKING(for msvc cl.exe (optional)) +# See if CC points to the MS compiler +if "$CC" 2>&1 | grep "Microsoft" >/dev/null; then + AC_MSG_RESULT([found, set as default]) + HAS_MSVC=yes + DEFAULT_COMPILER=_MSVC + DEFAULT_CIL_MODE=MSVC +else + if cl 2>&1 | grep "Microsoft" >/dev/null ;then + AC_MSG_RESULT(found) + HAS_MSVC=yes + else + AC_MSG_RESULT(not found) + HAS_MSVC=no + fi +fi + +# is ocaml available? +# needed binaries: ocamllex ocamlyacc ocamldep ocamlopt ocamlc +ocamlDownloadInstructions=" + OCaml can be downloaded from http://caml.inria.fr/ocaml/. + After downloading and unpacking the source distribution, in the ocaml + directory, do + ./configure + make world + make opt + make install + Then come back here and re-run ./configure." + +# required major/minor. +# required major/minor +reqMaj=3 +reqMin=08 +knownMaj=3 +knownMin=09 +AC_MSG_CHECKING(ocaml version is at least $reqMaj.$reqMin) +if binaryExists ocamlc; then + # what version? + ver=`ocamlc -v | grep version | sed 's/^.*version //'` + diagnostic "ver is $ver" + # major: anything before the . + major=`echo $ver | sed 's/\..*$//'` + diagnostic "major is $major" + # minor: numbers after the . + # (the outer level of bracket-quotation protects the inner brackets) + [minor=`echo $ver | sed 's/^[^.]*\.\([0-9][0-9]*\).*$/\1/'`] + diagnostic "minor is $minor" + + # I would think autoconf would already have a facility for doing + # these kinds of major/minor version checks, but I can't find it + if test $major -gt $reqMaj -o $major -ge $reqMaj -a $minor -ge $reqMin; then + AC_MSG_RESULT([version is $ver, ok]) + + # sm: added this test when we found that CCured needed to be changed + # a little when 3.06 came out (it had previously worked with 3.04) + if test "$major" -gt $knownMaj -o "$major" -ge $knownMaj -a "$minor" -gt $knownMin; then + AC_MSG_WARN([Your ocaml version is $ver, but the latest version this program + is known to work with is $knownMaj.$knownMin. If you have + trouble compiling, please try using an earlier version + or see if there is a later version of this program.]) + fi + else + AC_MSG_ERROR([ + I found OCaml version $ver; this program requires at least $reqMaj.$reqMin. + Please download a newer OCaml distribution. + $ocamlDownloadInstructions + ]) + fi + + # check for existence of other binaries + AC_MSG_CHECKING(existence of related ocaml tools) + if binaryExists ocamllex && \ + binaryExists ocamlyacc && \ + binaryExists ocamldep && \ + binaryExists ocamlopt; then + AC_MSG_RESULT(ok) + else + AC_MSG_ERROR([ + At least one of ocamllex, ocamlyacc, ocamldep or ocamlopt is missing. + In particular, ocamlopt requires you to "make opt" when building + OCaml from source. Please make sure all these tools are built and + in the path. + ]) + fi +else + AC_MSG_ERROR([ + The "ocamlc" OCaml compiler was not found in the path: $PATH. + + Most of this program is written in the OCaml language, so its compiler + is required. + $ocamlDownloadInstructions + ]) +fi + +# +# ------------------- Perl ---------------- +# +AC_MSG_CHECKING([for Perl]) + if ! binaryExists perl; then + AC_MSG_ERROR([ + perl not found. + You need perl version 5.6.1 or later for CIL. + You can get perl at http://www.cpan.org/src/index.html . + ]) + fi + + # sm: oh how nice it would be to just say "use English; + # print($PERL_VERSION)", but that appears broken on 5.6.1.. so I'm + # trying to say "caret right-bracket", but then that would run afoul + # of autoconf's quoting characters, so I use the "quadrigraph" @:>@ + # to stand for right-bracket. what a mess. + perlver=`perl -e 'print($@:>@);'` + if perl -e "exit( $perlver >= 5.006001 );"; then + AC_MSG_ERROR([ + Found perl version $perlver, but at least 5.6.1 is required. + You can get a newer perl at http://www.cpan.org/src/index.html . + ]) + fi + + perlport=`perl -e "print $^O;"` + case "$perlport" in + cygwin) + ;; + MSWin32) # ActivePerl + ;; + linux) + ;; + freebsd) + ;; + openbsd) + ;; + darwin) # Mac OS X + ;; + solaris) + ;; + *) + AC_MSG_ERROR([ + Unsupported Perl port $perlport -- sorry. + cygwin, MSWin32 (ActivePerl), linux, freebsd, openbsd, darwin, + and solaris are the supported ports. + ]) + esac +AC_MSG_RESULT([found version $perlver, port $perlport]) + + # The cygwin port has some bugs in the File::Spec module +if test "$perlport" = "cygwin" ;then + AC_MSG_CHECKING([for known cygwin Perl bug in File::Spec]) + perlfixres=[`perl -e ' + use File::Spec; + if(File::Spec->file_name_is_absolute("C:/test")) { + print "no bug found"; exit 0; + } else { + print "bug"; + foreach $d (@INC) { + if(-f "$d/File/Spec/Unix.pm") { + open(IN, "<$d/File/Spec/Unix.pm"); + open(OUT, ">$d/File/Spec/Unix.pm.fixed") + || die "Cannot open $d/File/Spec/Unix.pm.fixed"; + while() { + if($_ =~ m|sub file_name_is_absolute|) { + print OUT $_; + print OUT scalar(); + print OUT <file_name_is_absolute("C:/test")) { + print "bug fixed"; exit 0; + } else { + print "cannot fix bug"; exit 1; + }'` + fi + if test "x$perlfixres" = "x" ;then + AC_MSG_ERROR([ + Cannot run perl + ]) + elif test "$perlfixres" = "cannot fix bug" ;then + AC_MSG_ERROR([ + Found a bug but cannot fix it. + ]) + else + AC_MSG_RESULT([$perlfixres]) + fi +fi + +# +# Now setup the performance counters +# +AC_MSG_CHECKING(if performance counters are usable) +# Create a C file from src/perfcount.c.in +rm -f ./cycles.exe +if gcc -DCONFIGURATION_ONLY \ + -x c ocamlutil/perfcount.c.in -lm -o ./cycles.exe >/dev/null 2>&1; then + + if CYCLES_PER_USEC=`./cycles.exe 2>&1` ;then + AC_MSG_RESULT([ok ($CYCLES_PER_USEC cycles per us)]) + else + # Print what we got + AC_MSG_RESULT([no ($CYCLES_PER_USEC)]) + CYCLES_PER_USEC=0 + fi +else + CYCLES_PER_USEC=0 + AC_MSG_RESULT([no (cannot compile perfcount.c)]) +fi +rm -f ./cycles.exe + +# If we are on Linux and we use performance counters try to get +# the processor speed from /proc/cpuinfo +if test "$CYCLES_PER_USEC" != "0" ;then + case "$target" in + # linux + *86*linux*) + AC_MSG_CHECKING(if /proc/cpuinfo has processor speed) + cpuinfo=`cat /proc/cpuinfo 2>/dev/null | grep "cpu MHz"` + [procspeed=`echo $cpuinfo | sed 's/^.*[^0-9]\([0-9]\+\.[0-9]\+\).*$/\1/g'`] + if test "$procspeed"!="" ;then + CYCLES_PER_USEC=$procspeed + AC_MSG_RESULT([got $CYCLES_PER_USEC cycles per us]) + else + AC_MSG_RESULT(no) + fi + ;; + *) + ;; + esac + # Now set HAS_PERFCOUNT + HAS_PERFCOUNT=1 +else + HAS_PERFCOUNT=0 +fi + +# additional tools we might check for: +# - gnu make + +# +# -------------------- GCC -------------- +# + +AC_MSG_CHECKING([for gcc version]) +AC_CHECK_TYPE(__builtin_va_list, + HAVE_BUILTIN_VA_LIST=true, + HAVE_BUILTIN_VA_LIST=false) +AC_MSG_CHECKING([if __thread is a keyword]) +AC_COMPILE_IFELSE([int main(int __thread) { return 0; }], + THREAD_IS_KEYWORD=false, + THREAD_IS_KEYWORD=true) +AC_MSG_RESULT($THREAD_IS_KEYWORD) + +# Does gcc add underscores to identifiers to make assembly labels? +# (I think MSVC always does) +AC_MSG_CHECKING([if gcc adds underscores to assembly labels.]) +AC_LINK_IFELSE([int main() { __asm__("jmp _main"); }], + UNDERSCORE_NAME=true, + UNDERSCORE_NAME=false) +AC_MSG_RESULT($UNDERSCORE_NAME) + + +# ----------- some stuff 'autoscan' put here -------------- +# (autoscan is part of the autoconf distribution) + +# checks for header files +AC_HEADER_STDC +AC_CHECK_HEADERS(stdlib.h strings.h sys/time.h unistd.h wchar.h) + +# checks for typedefs, structures, and compiler characteristics +AC_C_CONST +AC_C_INLINE +AC_HEADER_TIME + +# checks for library functions; more autoscan stuff +AC_FUNC_MEMCMP +AC_CHECK_FUNCS(mkdir select socket __sysv_signal) + + + +# ----------- platform-specific code ------------- +# $target is typically processor-vendor-os +case "$target" in + # linux + *86*linux*|*86*freebsd*|*86*openbsd*|*86*darwin*) + AC_MSG_RESULT(configuring for linux/x86) + + ARCHOS=x86_LINUX + ;; + + # Mac OS X + *powerpc*darwin*) + AC_MSG_RESULT(configuring for powerpc/darwin, which we treat like linux/x86) + + ARCHOS=ppc_DARWIN + ;; + + # cygwin + *86*cygwin*) + AC_MSG_RESULT(configuring for Cygwin on win32/x86) + + ARCHOS=x86_WIN32 + + # override CILHOME; even on cygwin we want forward slashes + # sm: I folded this into what I hope will be the only + # case-analysis of machine type + CILHOME=`cygpath -wa "$CILHOME" | sed -e "s/\\\\\/\\//g"` + CC=`which $CC` + CC=`cygpath -wa "$CC" | sed -e "s/\\\\\/\\//g"` + ;; + + # Solaris + *sparc*solaris*) + AC_MSG_RESULT(configuring for SPARC/Solaris) + + ARCHOS=sparc_SOLARIS + ;; + + *) + AC_MSG_ERROR([ + Unsupported platform $target -- sorry. + ./configure supports these platforms: + on x86: Linux, Win32(with Cygwin), freeBSD, openBSD, and Mac OS X + on PowerPC: Mac OS X + on SPARC: Solaris + ]) + ;; +esac + +# Make the object directory if not already present +AC_CHECK_FILE(obj/$ARCHOS,, AC_MSG_RESULT(creating obj/$ARCHOS); + mkdir -p obj/$ARCHOS) + +AC_MSG_CHECKING([delete the obj/$ARCHOS/feature_config.ml and obj/$ARCHOS/machdep.ml file]) +rm -f obj/$ARCHOS/machdep.ml +rm -f obj/.depend/machdep.d +rm -f obj/$ARCHOS/feature_config.ml +rm -f obj/.depend/feature_config.d +AC_MSG_RESULT([done]) + +# We will use substitution variables whose definition contains newlines. The +# problem is that when config.status runs, it wants to break the series of +# substitution commands for sed into fragments based on line count. We could +# be unlucky and have config.status break the series of substitution in the +# middle of a variable that contains newlines. So, we first create a single +# variable called NEWLINE whose definition is a carriage return. This means +# that there will be exactly one opportunity for this error to happen (in the +# definition of NEWLINE). The occurrence of AC_SUBST for NEWLINE must occur +# after those of the variables that use it! And we want to put all of these +# very early on, to make sure that they are not around the place when the file +# bets broken. + +NEWLINE="\\ +" + + +# +# CIL/CCured features +# +# + +# Set the defaults + + +# Give a space-separated list of features with the defaults +features="blockinggraph=no rand=no arithabs=no zrapp=no" + +AC_ARG_WITH(blockinggraph, + AC_HELP_STRING([--with-blockinggraph], + [enable the blocking graph feature])) +AC_ARG_WITH(rand, + AC_HELP_STRING([--with-rand], + [enable the randomized value numbering])) +AC_ARG_WITH(arithabs, + AC_HELP_STRING([--with-arithabs], + [enable the arithmetic abstraction])) +AC_ARG_WITH(zrapp, + AC_HELP_STRING([--with-zrapp], + [enable the zrapp pretty-printer])) + +# Smalloc.ml is distributed by {matth,nks}@cs.berkeley.edu as part of Scrash. +features="$features smalloc=no" + +# cqualann.ml is used by Matt Harren. Please ignore. +features="$features cqualann=no" + +# Now add any features specified in the command-line + +features="$features $EXTRAFEATURES" + +for f_val in $features +do + # If there is no =, then we default to yes + if ! (echo $f_val | grep "=" >/dev/null) ;then f_val="$f_val=yes"; fi + # echo "Testing feature $f_val" + f=`echo $f_val | sed -e s%=.*$%%` + AC_MSG_CHECKING(whether to use CIL feature $f) + # default value from "features" + defval=`echo $f_val | sed -e s%^.*=%%` + # current value + getcurval="echo \${with_$f:=$defval}" + curval=`eval $getcurval` + AC_MSG_RESULT($curval) + if test $curval = yes ;then + CIL_FEATURES="$CIL_FEATURES $f" + fi +done + +## Now produce the CIL_FEATURES_DEFINES +CIL_FEATURES_DEFINES="" +# Convert to upper case +for f in `echo $CIL_FEATURES | tr a-z A-Z` +do + CIL_FEATURES_DEFINES="${CIL_FEATURES_DEFINES}@NEWLINE@export USE_$f=yes" +done + + +# ----------------- finish up ------------------- +# names of the variables that get substituted in files; for example, +# write @ARCHOS@ somewhere in a written file to get it substituted +AC_SUBST(ARCHOS) +AC_SUBST(CILHOME) +AC_SUBST(HAS_MSVC) +AC_SUBST(DEFAULT_COMPILER) +AC_SUBST(DEFAULT_CIL_MODE) +AC_SUBST(CIL_VERSION_MAJOR) +AC_SUBST(CIL_VERSION_MINOR) +AC_SUBST(CIL_VERSION_REV) +AC_SUBST(CIL_VERSION) +AC_SUBST(CYCLES_PER_USEC) +AC_SUBST(HAS_PERFCOUNT) +AC_SUBST(HAVE_BUILTIN_VA_LIST) +AC_SUBST(THREAD_IS_KEYWORD) +AC_SUBST(UNDERSCORE_NAME) +AC_SUBST(EXTRAFEATURES) +AC_SUBST(EXTRASRCDIRS) + +# finish the configure script and generate various files; ./configure +# will apply variable substitutions to .in to generate ; +# I find it useful to mark generated files as read-only so I don't +# accidentally edit them (and them lose my changes when ./configure +# runs again); I had originally done the chmod after AC_OUTPUT, but +# the problem is then the chmod doesn't run inside ./config.status + +# MY_AC_CONFIG_FILES(filename) +# do AC_CONFIG_FILES(filename, chmod a-w filename) +define([MY_AC_CONFIG_FILES], +[{ + if test -f [$1].in; then + AC_CONFIG_FILES([$1], chmod a-w [$1]) + else + true + #echo "skipping [$1] because it's not in this distribution" + fi +}]) +define([MY_AC_CONFIG_EXE_FILES], +[{ + if test -f [$1].in; then + AC_CONFIG_FILES([$1], [chmod a-w,a+x $1]) + else + true + #echo "skipping [$1] because it's not in this distribution" + fi +}]) + +MY_AC_CONFIG_FILES(Makefile) +MY_AC_CONFIG_FILES(cil.spec) +MY_AC_CONFIG_FILES(config.mk) +MY_AC_CONFIG_FILES(test/Makefile) +MY_AC_CONFIG_EXE_FILES(bin/cilly.bat) +MY_AC_CONFIG_EXE_FILES(bin/patcher.bat) +MY_AC_CONFIG_FILES(bin/CilConfig.pm) +MY_AC_CONFIG_FILES(doc/index.html) +MY_AC_CONFIG_FILES(doc/header.html) +MY_AC_CONFIG_FILES(ocamlutil/perfcount.c) + +AC_OUTPUT() + +# show the user what the variables have been set to +cat < + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Alpha + + +
Previous + Up + Next +
+

Module Alpha

+
+
module Alpha: sig .. end
ALPHA conversion
+
+
type 'a undoAlphaElement
+
+This is the type of the elements that are recorded by the alpha + conversion functions in order to be able to undo changes to the tables + they modify. Useful for implementing + scoping
+
+ +
type 'a alphaTableData
+
+This is the type of the elements of the alpha renaming table. These + elements can carry some data associated with each occurrence of the name.
+
+ +
val newAlphaName : alphaTable:(string, 'a alphaTableData Pervasives.ref) Hashtbl.t ->
       undolist:'a undoAlphaElement list Pervasives.ref option ->
       lookupname:string -> data:'a -> string * 'a
+Create a new name based on a given name. The new name is formed from a + prefix (obtained from the given name by stripping a suffix consisting of _ + followed by only digits), followed by a special separator and then by a + positive integer suffix. The first argument is a table mapping name + prefixes to some data that specifies what suffixes have been used and how + to create the new one. This function updates the table with the new + largest suffix generated. The "undolist" argument, when present, will be + used by the function to record information that can be used by + Alpha.undoAlphaChanges to undo those changes. Note that the undo + information will be in reverse order in which the action occurred. Returns + the new name and, if different from the lookupname, the location of the + previous occurrence. This function knows about the location implicitly + from the Cil.currentLoc.
+
+
val registerAlphaName : alphaTable:(string, 'a alphaTableData Pervasives.ref) Hashtbl.t ->
       undolist:'a undoAlphaElement list Pervasives.ref option ->
       lookupname:string -> data:'a -> unit
+Register a name with an alpha conversion table to ensure that when later + we call newAlphaName we do not end up generating this one
+
+
val docAlphaTable : unit ->
       (string, 'a alphaTableData Pervasives.ref) Hashtbl.t -> Pretty.doc
+Split the name in preparation for newAlphaName. The prefix returned is + used to index into the hashtable. The next result value is a separator + (either empty or the separator chosen to separate the original name from + the index)
+
+
val getAlphaPrefix : lookupname:string -> string
val undoAlphaChanges : alphaTable:(string, 'a alphaTableData Pervasives.ref) Hashtbl.t ->
       undolist:'a undoAlphaElement list -> unit
+Undo the changes to a table
+
+ \ No newline at end of file diff --git a/cil/doc/api/Cfg.html b/cil/doc/api/Cfg.html new file mode 100644 index 0000000..142de8a --- /dev/null +++ b/cil/doc/api/Cfg.html @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cfg + + +
Previous + Up + Next +
+

Module Cfg

+
+
module Cfg: sig .. end
Code to compute the control-flow graph of a function or file. + This will fill in the preds and succs fields of Cil.stmt +

+ + This is required for several other extensions, such as Dataflow.
+

+
val computeFileCFG : Cil.file -> unit
+Compute the CFG for an entire file, by calling cfgFun on each function.
+
+
val clearFileCFG : Cil.file -> unit
+clear the sid, succs, and preds fields of each statement.
+
+
val cfgFun : Cil.fundec -> int
+Compute a control flow graph for fd. Stmts in fd have preds and succs + filled in
+
+
val clearCFGinfo : Cil.fundec -> unit
+clear the sid, succs, and preds fields of each statment in a function
+
+
val printCfgChannel : Pervasives.out_channel -> Cil.fundec -> unit
+print control flow graph (in dot form) for fundec to channel
+
+
val printCfgFilename : string -> Cil.fundec -> unit
+Print control flow graph (in dot form) for fundec to file
+
+
val start_id : int Pervasives.ref
+Next statement id that will be assigned.
+
+
val nodeList : Cil.stmt list Pervasives.ref
+All of the nodes in a file.
+
+
val numNodes : int Pervasives.ref
+number of nodes in the CFG
+
+ \ No newline at end of file diff --git a/cil/doc/api/Cil.cilPrinter.html b/cil/doc/api/Cil.cilPrinter.html new file mode 100644 index 0000000..1b9511f --- /dev/null +++ b/cil/doc/api/Cil.cilPrinter.html @@ -0,0 +1,118 @@ + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cil.cilPrinter + + +
Previous + Up + 
+

Class type Cil.cilPrinter

+
+
class type cilPrinter = object .. end
A printer interface for CIL trees. Create instantiations of + this type by specializing the class Cil.defaultCilPrinterClass.
+
+
method pVDecl : unit -> varinfo -> Pretty.doc
+Invoked for each variable declaration. Note that variable + declarations are all the GVar, GVarDecl, GFun, all the varinfo + in formals of function types, and the formals and locals for function + definitions.
+
+
method pVar : varinfo -> Pretty.doc
+Invoked on each variable use.
+
+
method pLval : unit -> lval -> Pretty.doc
+Invoked on each lvalue occurrence
+
+
method pOffset : Pretty.doc -> offset -> Pretty.doc
+Invoked on each offset occurrence. The second argument is the base.
+
+
method pInstr : unit -> instr -> Pretty.doc
+Invoked on each instruction occurrence.
+
+
method pLabel : unit -> label -> Pretty.doc
+Print a label.
+
+
method pStmt : unit -> stmt -> Pretty.doc
+Control-flow statement. This is used by + Cil.printGlobal and by Cil.dumpGlobal.
+
+
method dStmt : Pervasives.out_channel -> int -> stmt -> unit
+Dump a control-flow statement to a file with a given indentation. + This is used by Cil.dumpGlobal.
+
+
method dBlock : Pervasives.out_channel -> int -> block -> unit
+Dump a control-flow block to a file with a given indentation. + This is used by Cil.dumpGlobal.
+
+
method pBlock : unit -> block -> Pretty.doc
method pBlock : unit -> block -> Pretty.doc
+Print a block.
+
+
method pGlobal : unit -> global -> Pretty.doc
+Global (vars, types, etc.). This can be slow and is used only by + Cil.printGlobal but not by Cil.dumpGlobal.
+
+
method dGlobal : Pervasives.out_channel -> global -> unit
+Dump a global to a file with a given indentation. This is used by + Cil.dumpGlobal
+
+
method pFieldDecl : unit -> fieldinfo -> Pretty.doc
+A field declaration
+
+
method pType : Pretty.doc option -> unit -> typ -> Pretty.doc
method pAttr : attribute -> Pretty.doc * bool
+Attribute. Also return an indication whether this attribute must be + printed inside the __attribute__ list or not.
+
+
method pAttrParam : unit -> attrparam -> Pretty.doc
+Attribute parameter
+
+
method pAttrs : unit -> attributes -> Pretty.doc
+Attribute lists
+
+
method pLineDirective : ?forcefile:bool -> location -> Pretty.doc
+Print a line-number. This is assumed to come always on an empty line. + If the forcefile argument is present and is true then the file name + will be printed always. Otherwise the file name is printed only if it + is different from the last time time this function is called. The last + file name is stored in a private field inside the cilPrinter object.
+
+
method pStmtKind : stmt -> unit -> stmtkind -> Pretty.doc
+Print a statement kind. The code to be printed is given in the + Cil.stmtkind argument. The initial Cil.stmt argument + records the statement which follows the one being printed; + Cil.defaultCilPrinterClass uses this information to prettify + statement printing in certain special cases.
+
+
method pExp : unit -> exp -> Pretty.doc
+Print expressions
+
+
method pInit : unit -> init -> Pretty.doc
+Print initializers. This can be slow and is used by + Cil.printGlobal but not by Cil.dumpGlobal.
+
+
method dInit : Pervasives.out_channel -> int -> init -> unit
+Dump a global to a file with a given indentation. This is used by + Cil.dumpGlobal
+
+ \ No newline at end of file diff --git a/cil/doc/api/Cil.cilVisitor.html b/cil/doc/api/Cil.cilVisitor.html new file mode 100644 index 0000000..f8c6496 --- /dev/null +++ b/cil/doc/api/Cil.cilVisitor.html @@ -0,0 +1,125 @@ + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cil.cilVisitor + + +
 Up + Next +
+

Class type Cil.cilVisitor

+
+
class type cilVisitor = object .. end
A visitor interface for traversing CIL trees. Create instantiations of + this type by specializing the class Cil.nopCilVisitor. Each of the + specialized visiting functions can also call the queueInstr to specify + that some instructions should be inserted before the current instruction + or statement. Use syntax like self#queueInstr to call a method + associated with the current object.
+
+
method vvdec : varinfo -> varinfo visitAction
+Invoked for each variable declaration. The subtrees to be traversed + are those corresponding to the type and attributes of the variable. + Note that variable declarations are all the GVar, GVarDecl, GFun, + all the varinfo in formals of function types, and the formals and + locals for function definitions. This means that the list of formals + in a function definition will be traversed twice, once as part of the + function type and second as part of the formals in a function + definition.
+
+
method vvrbl : varinfo -> varinfo visitAction
+Invoked on each variable use. Here only the SkipChildren and + ChangeTo actions make sense since there are no subtrees. Note that + the type and attributes of the variable are not traversed for a + variable use
+
+
method vexpr : exp -> exp visitAction
+Invoked on each expression occurrence. The subtrees are the + subexpressions, the types (for a Cast or SizeOf expression) or the + variable use.
+
+
method vlval : lval -> lval visitAction
+Invoked on each lvalue occurrence
+
+
method voffs : offset -> offset visitAction
+Invoked on each offset occurrence that is *not* as part + of an initializer list specification, i.e. in an lval or + recursively inside an offset.
+
+
method vinitoffs : offset -> offset visitAction
+Invoked on each offset appearing in the list of a + CompoundInit initializer.
+
+
method vinst : instr -> instr list visitAction
+Invoked on each instruction occurrence. The ChangeTo action can + replace this instruction with a list of instructions
+
+
method vstmt : stmt -> stmt visitAction
+Control-flow statement. The default DoChildren action does not + create a new statement when the components change. Instead it updates + the contents of the original statement. This is done to preserve the + sharing with Goto and Case statements that point to the original + statement. If you use the ChangeTo action then you should take care + of preserving that sharing yourself.
+
+
method vblock : block -> block visitAction
+Block.
+
+
method vfunc : fundec -> fundec visitAction
+Function definition. + Replaced in place.
+
+
method vglob : global -> global list visitAction
+Global (vars, types, + etc.)
+
+
method vinit : init -> init visitAction
+Initializers for globals
+
+
method vtype : typ -> typ visitAction
+Use of some type. Note + that for structure/union + and enumeration types the + definition of the + composite type is not + visited. Use vglob to + visit it.
+
+
method vattr : attribute -> attribute list visitAction
+Attribute. Each attribute can be replaced by a list
+
+
method vattrparam : attrparam -> attrparam visitAction
+Attribute parameters.
+
+
method queueInstr : instr list -> unit
+Add here instructions while visiting to queue them to preceede the + current statement or instruction being processed. Use this method only + when you are visiting an expression that is inside a function body, or + a statement, because otherwise there will no place for the visitor to + place your instructions.
+
+
method unqueueInstr : unit -> instr list
+Gets the queue of instructions and resets the queue. This is done + automatically for you when you visit statments.
+
+ \ No newline at end of file diff --git a/cil/doc/api/Cil.defaultCilPrinterClass.html b/cil/doc/api/Cil.defaultCilPrinterClass.html new file mode 100644 index 0000000..d859559 --- /dev/null +++ b/cil/doc/api/Cil.defaultCilPrinterClass.html @@ -0,0 +1,36 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cil.defaultCilPrinterClass + + +
Previous + Up + Next +
+

Class Cil.defaultCilPrinterClass

+
+
class defaultCilPrinterClass : cilPrinter
+ \ No newline at end of file diff --git a/cil/doc/api/Cil.html b/cil/doc/api/Cil.html new file mode 100644 index 0000000..f2e09c2 --- /dev/null +++ b/cil/doc/api/Cil.html @@ -0,0 +1,3337 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cil + + +
Previous + Up + Next +
+

Module Cil

+
+
module Cil: sig .. end
CIL API Documentation. An html version of this document can be found at + http://manju.cs.berkeley.edu/cil.
+
+
val initCIL : unit -> unit
+Call this function to perform some initialization. Call if after you have + set Cil.msvcMode.
+
+
val cilVersion : string
+This are the CIL version numbers. A CIL version is a number of the form + M.m.r (major, minor and release)
+
+
val cilVersionMajor : int
val cilVersionMinor : int
val cilVersionRevision : int

+This module defines the abstract syntax of CIL. It also provides utility + functions for traversing the CIL data structures, and pretty-printing + them. The parser for both the GCC and MSVC front-ends can be invoked as + Frontc.parse: string -> unit -> Cil.file. This function must be given + the name of a preprocessed C file and will return the top-level data + structure that describes a whole source file. By default the parsing and + elaboration into CIL is done as for GCC source. If you want to use MSVC + source you must set the Cil.msvcMode to true and must also invoke the + function Frontc.setMSVCMode: unit -> unit.
+
+The Abstract Syntax of CIL
+
+The top-level representation of a CIL source file (and the result of the + parsing and elaboration). Its main contents is the list of global + declarations and definitions. You can iterate over the globals in a + Cil.file using the following iterators: Cil.mapGlobals, + Cil.iterGlobals and Cil.foldGlobals. You can also use the + Cil.dummyFile when you need a Cil.file as a placeholder. For each + global item CIL stores the source location where it appears (using the + type Cil.location)
+
type file = { + + + + + + + + + + + + + + + + + + + +
+   +mutable fileName : string;(*The complete file name*)
+   +mutable globals : global list;(*List of globals as they will appear + in the printed file*)
+   +mutable globinit : fundec option;(*An optional global initializer function. This is a function where + you can put stuff that must be executed before the program is + started. This function, is conceptually at the end of the file, + although it is not part of the globals list. Use Cil.getGlobInit + to create/get one.*)
+   +mutable globinitcalled : bool;(*Whether the global initialization function is called in main. This + should always be false if there is no global initializer. When you + create a global initialization CIL will try to insert code in main + to call it. This will not happen if your file does not contain a + function called "main"*)
+} + +
+Top-level representation of a C source file
+
+ +
type comment = location * string
+ +
+Globals. The main type for representing global declarations and + definitions. A list of these form a CIL file. The order of globals in the + file is generally important.
+
type global = + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+| +GType of typeinfo * location(*A typedef. All uses of type names (through the TNamed constructor) + must be preceded in the file by a definition of the name. The string + is the defined name and always not-empty.*)
+| +GCompTag of compinfo * location(*Defines a struct/union tag with some fields. There must be one of + these for each struct/union tag that you use (through the TComp + constructor) since this is the only context in which the fields are + printed. Consequently nested structure tag definitions must be + broken into individual definitions with the innermost structure + defined first.*)
+| +GCompTagDecl of compinfo * location(*Declares a struct/union tag. Use as a forward declaration. This is + printed without the fields.*)
+| +GEnumTag of enuminfo * location(*Declares an enumeration tag with some fields. There must be one of + these for each enumeration tag that you use (through the TEnum + constructor) since this is the only context in which the items are + printed.*)
+| +GEnumTagDecl of enuminfo * location(*Declares an enumeration tag. Use as a forward declaration. This is + printed without the items.*)
+| +GVarDecl of varinfo * location(*A variable declaration (not a definition). If the variable has a + function type then this is a prototype. There can be several + declarations and at most one definition for a given variable. If both + forms appear then they must share the same varinfo structure. A + prototype shares the varinfo with the fundec of the definition. Either + has storage Extern or there must be a definition in this file*)
+| +GVar of varinfo * initinfo * location(*A variable definition. Can have an initializer. The initializer is + updateable so that you can change it without requiring to recreate + the list of globals. There can be at most one definition for a + variable in an entire program. Cannot have storage Extern or function + type.*)
+| +GFun of fundec * location(*A function definition.*)
+| +GAsm of string * location(*Global asm statement. These ones + can contain only a template*)
+| +GPragma of attribute * location(*Pragmas at top level. Use the same + syntax as attributes*)
+| +GText of string(*Some text (printed verbatim) at + top level. E.g., this way you can + put comments in the output.*)
+ +
+A global declaration or definition
+
+ +
+Types. A C type is represented in CIL using the type Cil.typ. + Among types we differentiate the integral types (with different kinds + denoting the sign and precision), floating point types, enumeration types, + array and pointer types, and function types. Every type is associated with + a list of attributes, which are always kept in sorted order. Use + Cil.addAttribute and Cil.addAttributes to construct list of + attributes. If you want to inspect a type, you should use + Cil.unrollType or Cil.unrollTypeDeep to see through the uses of + named types.
+
+CIL is configured at build-time with the sizes and alignments of the + underlying compiler (GCC or MSVC). CIL contains functions that can compute + the size of a type (in bits) Cil.bitsSizeOf, the alignment of a type + (in bytes) Cil.alignOf_int, and can convert an offset into a start and + width (both in bits) using the function Cil.bitsOffset. At the moment + these functions do not take into account the packed attributes and + pragmas.
+
type typ = + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+| +TVoid of attributes(*Void type. Also predefined as Cil.voidType*)
+| +TInt of ikind * attributes(*An integer type. The kind specifies the sign and width. Several + useful variants are predefined as Cil.intType, Cil.uintType, + Cil.longType, Cil.charType.*)
+| +TFloat of fkind * attributes(*A floating-point type. The kind specifies the precision. You can + also use the predefined constant Cil.doubleType.*)
+| +TPtr of typ * attributes(*Pointer type. Several useful variants are predefined as + Cil.charPtrType, Cil.charConstPtrType (pointer to a + constant character), Cil.voidPtrType, + Cil.intPtrType*)
+| +TArray of typ * exp option * attributes(*Array type. It indicates the base type and the array length.*)
+| +TFun of typ * (string * typ * attributes) list option * bool
* attributes		(*Function type. Indicates the type of the result, the name, type + and name attributes of the formal arguments (None if no + arguments were specified, as in a function whose definition or + prototype we have not seen; Some [] means void). Use + Cil.argsToList to obtain a list of arguments. The boolean + indicates if it is a variable-argument function. If this is the + type of a varinfo for which we have a function declaration then + the information for the formals must match that in the + function's sformals. Use Cil.setFormals, or + Cil.setFunctionType, or Cil.makeFormalVar for this + purpose.*)
+| +TNamed of typeinfo * attributes
+| +TComp of compinfo * attributes(*The most delicate issue for C types is that recursion that is possible by + using structures and pointers. To address this issue we have a more + complex representation for structured types (struct and union). Each such + type is represented using the Cil.compinfo type. For each composite + type the Cil.compinfo structure must be declared at top level using + GCompTag and all references to it must share the same copy of the + structure. The attributes given are those pertaining to this use of the + type and are in addition to the attributes that were given at the + definition of the type and which are stored in the Cil.compinfo.*)
+| +TEnum of enuminfo * attributes(*A reference to an enumeration type. All such references must + share the enuminfo among them and with a GEnumTag global that + precedes all uses. The attributes refer to this use of the + enumeration and are in addition to the attributes of the + enumeration itself, which are stored inside the enuminfo*)
+| +TBuiltin_va_list of attributes(*This is the same as the gcc's type with the same name*)
+ + +
+There are a number of functions for querying the kind of a type. These are + Cil.isIntegralType, + Cil.isArithmeticType, + Cil.isPointerType, + Cil.isFunctionType, + Cil.isArrayType. +

+ + There are two easy ways to scan a type. First, you can use the +Cil.existsType to return a boolean answer about a type. This function +is controlled by a user-provided function that is queried for each type that is +used to construct the current type. The function can specify whether to +terminate the scan with a boolean result or to continue the scan for the +nested types. +

+ + The other method for scanning types is provided by the visitor interface (see + Cil.cilVisitor). +

+ + If you want to compare types (or to use them as hash-values) then you should +use instead type signatures (represented as Cil.typsig). These +contain the same information as types but canonicalized such that simple Ocaml +structural equality will tell whether two types are equal. Use +Cil.typeSig to compute the signature of a type. If you want to ignore +certain type attributes then use Cil.typeSigWithAttrs.
+
type ikind = + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+| +IChar(*char*)
+| +ISChar(*signed char*)
+| +IUChar(*unsigned char*)
+| +IInt(*int*)
+| +IUInt(*unsigned int*)
+| +IShort(*short*)
+| +IUShort(*unsigned short*)
+| +ILong(*long*)
+| +IULong(*unsigned long*)
+| +ILongLong(*long long (or _int64 on Microsoft Visual C)*)
+| +IULongLong(*unsigned long long (or unsigned _int64 on Microsoft + Visual C)*)
+ +

+Various kinds of integers
+
+ +
type fkind = + + + + + + + + + + + + + + +
+| +FFloat(*float*)
+| +FDouble(*double*)
+| +FLongDouble(*long double*)
+ +
+Various kinds of floating-point numbers
+
+ +
+Attributes.
+
type attribute = + + + + +
+| +Attr of string * attrparam list(*An attribute has a name and some optional parameters. The name should not + start or end with underscore. When CIL parses attribute names it will + strip leading and ending underscores (to ensure that the multitude of GCC + attributes such as const, __const and __const__ all mean the same thing.)*)
+ + +
type attributes = attribute list
+
+Attributes are lists sorted by the attribute name. Use the functions + Cil.addAttribute and Cil.addAttributes to insert attributes in an + attribute list and maintain the sortedness.
+
+ +
type attrparam = + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+| +AInt of int(*An integer constant*)
+| +AStr of string(*A string constant*)
+| +ACons of string * attrparam list(*Constructed attributes. These + are printed foo(a1,a2,...,an). + The list of parameters can be + empty and in that case the + parentheses are not printed.*)
+| +ASizeOf of typ(*A way to talk about types*)
+| +ASizeOfE of attrparam
+| +ASizeOfS of typsig(*Replacement for ASizeOf in type + signatures. Only used for + attributes inside typsigs.*)
+| +AAlignOf of typ
+| +AAlignOfE of attrparam
+| +AAlignOfS of typsig
+| +AUnOp of unop * attrparam
+| +ABinOp of binop * attrparam * attrparam
+| +ADot of attrparam * string(*a.foo **)
+ +
+The type of parameters of attributes
+
+ +
+Structures. The Cil.compinfo describes the definition of a + structure or union type. Each such Cil.compinfo must be defined at the + top-level using the GCompTag constructor and must be shared by all + references to this type (using either the TComp type constructor or from + the definition of the fields. +

+ + If all you need is to scan the definition of each + composite type once, you can do that by scanning all top-level GCompTag. +

+ + Constructing a Cil.compinfo can be tricky since it must contain fields + that might refer to the host Cil.compinfo and furthermore the type of + the field might need to refer to the Cil.compinfo for recursive types. + Use the Cil.mkCompInfo function to create a Cil.compinfo. You can + easily fetch the Cil.fieldinfo for a given field in a structure with + Cil.getCompField.
+
type compinfo = { + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+   +mutable cstruct : bool;(*True if struct, False if union*)
+   +mutable cname : string;(*The name. Always non-empty. Use Cil.compFullName to get the full + name of a comp (along with the struct or union)*)
+   +mutable ckey : int;(*A unique integer. This is assigned by Cil.mkCompInfo using a + global variable in the Cil module. Thus two identical structs in two + different files might have different keys. Use Cil.copyCompInfo to + copy structures so that a new key is assigned.*)
+   +mutable cfields : fieldinfo list;(*Information about the fields. Notice that each fieldinfo has a + pointer back to the host compinfo. This means that you should not + share fieldinfo's between two compinfo's*)
+   +mutable cattr : attributes;(*The attributes that are defined at the same time as the composite + type. These attributes can be supplemented individually at each + reference to this compinfo using the TComp type constructor.*)
+   +mutable cdefined : bool;(*This boolean flag can be used to distinguish between structures + that have not been defined and those that have been defined but have + no fields (such things are allowed in gcc).*)
+   +mutable creferenced : bool;(*True if used. Initially set to false.*)
+} + +

+The definition of a structure or union type. Use Cil.mkCompInfo to + make one and use Cil.copyCompInfo to copy one (this ensures that a new + key is assigned and that the fields have the right pointers to parents.).
+
+ +
+Structure fields. The Cil.fieldinfo structure is used to describe + a structure or union field. Fields, just like variables, can have + attributes associated with the field itself or associated with the type of + the field (stored along with the type of the field).
+
type fieldinfo = { + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+   +mutable fcomp : compinfo;(*The host structure that contains this field. There can be only one + compinfo that contains the field.*)
+   +mutable fname : string;(*The name of the field. Might be the value of Cil.missingFieldName + in which case it must be a bitfield and is not printed and it does not + participate in initialization*)
+   +mutable ftype : typ;(*The type*)
+   +mutable fbitfield : int option;(*If a bitfield then ftype should be an integer type and the width of + the bitfield must be 0 or a positive integer smaller or equal to the + width of the integer type. A field of width 0 is used in C to control + the alignment of fields.*)
+   +mutable fattr : attributes;(*The attributes for this field (not for its type)*)
+   +mutable floc : location;(*The location where this field is defined*)
+} + +
+Information about a struct/union field
+
+ +
+Enumerations. Information about an enumeration. This is shared by all + references to an enumeration. Make sure you have a GEnumTag for each of + of these.
+
type enuminfo = { + + + + + + + + + + + + + + + + + + + +
+   +mutable ename : string;(*The name. Always non-empty.*)
+   +mutable eitems : (string * exp * location) list;(*Items with names and values. This list should be non-empty. The item + values must be compile-time constants.*)
+   +mutable eattr : attributes;(*The attributes that are defined at the same time as the enumeration + type. These attributes can be supplemented individually at each + reference to this enuminfo using the TEnum type constructor.*)
+   +mutable ereferenced : bool;(*True if used. Initially set to false*)
+} + +
+Information about an enumeration
+
+ +
+Enumerations. Information about an enumeration. This is shared by all + references to an enumeration. Make sure you have a GEnumTag for each of + of these.
+
type typeinfo = { + + + + + + + + + + + + + + +
+   +mutable tname : string;(*The name. Can be empty only in a GType when introducing a composite + or enumeration tag. If empty cannot be referred to from the file*)
+   +mutable ttype : typ;(*The actual type. This includes the attributes that were present in + the typedef*)
+   +mutable treferenced : bool;(*True if used. Initially set to false*)
+} + +
+Information about a defined type
+
+ +
+Variables. + Each local or global variable is represented by a unique Cil.varinfo +structure. A global Cil.varinfo can be introduced with the GVarDecl or +GVar or GFun globals. A local varinfo can be introduced as part of a +function definition Cil.fundec. +

+ + All references to a given global or local variable must refer to the same +copy of the varinfo. Each varinfo has a globally unique identifier that +can be used to index maps and hashtables (the name can also be used for this +purpose, except for locals from different functions). This identifier is +constructor using a global counter. +

+ + It is very important that you construct varinfo structures using only one + of the following functions:

+ + A varinfo is also used in a function type to denote the list of formals.
+
type varinfo = { + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+   +mutable vname : string;(*The name of the variable. Cannot be empty. It is primarily your + responsibility to ensure the uniqueness of a variable name. For local + variables Cil.makeTempVar helps you ensure that the name is unique.*)
+   +mutable vtype : typ;(*The declared type of the variable.*)
+   +mutable vattr : attributes;(*A list of attributes associated with the variable.*)
+   +mutable vstorage : storage;(*The storage-class*)
+   +mutable vglob : bool;(*True if this is a global variable*)
+   +mutable vinline : bool;(*Whether this varinfo is for an inline function.*)
+   +mutable vdecl : location;(*Location of variable declaration.*)
+   +mutable vid : int;(*A unique integer identifier. This field will be + set for you if you use one of the Cil.makeFormalVar, + Cil.makeLocalVar, Cil.makeTempVar, Cil.makeGlobalVar, or + Cil.copyVarinfo.*)
+   +mutable vaddrof : bool;(*True if the address of this variable is taken. CIL will set these + flags when it parses C, but you should make sure to set the flag + whenever your transformation create AddrOf expression.*)
+   +mutable vreferenced : bool;(*True if this variable is ever referenced. This is computed by + removeUnusedVars. It is safe to just initialize this to False*)
+} + +
+Information about a variable.
+
+ +
type storage = + + + + + + + + + + + + + + + + + + + +
+| +NoStorage(*The default storage. Nothing is printed*)
+| +Static
+| +Register
+| +Extern
+ +
+Storage-class information
+
+ +
+Expressions. The CIL expression language contains only the side-effect free expressions of +C. They are represented as the type Cil.exp. There are several +interesting aspects of CIL expressions: +

+ + Integer and floating point constants can carry their textual representation. +This way the integer 15 can be printed as 0xF if that is how it occurred in the +source. +

+ + CIL uses 64 bits to represent the integer constants and also stores the width +of the integer type. Care must be taken to ensure that the constant is +representable with the given width. Use the functions Cil.kinteger, +Cil.kinteger64 and Cil.integer to construct constant +expressions. CIL predefines the constants Cil.zero, +Cil.one and Cil.mone (for -1). +

+ + Use the functions Cil.isConstant and Cil.isInteger to test if +an expression is a constant and a constant integer respectively. +

+ + CIL keeps the type of all unary and binary expressions. You can think of that +type qualifying the operator. Furthermore there are different operators for +arithmetic and comparisons on arithmetic types and on pointers. +

+ + Another unusual aspect of CIL is that the implicit conversion between an +expression of array type and one of pointer type is made explicit, using the +StartOf expression constructor (which is not printed). If you apply the +AddrOf}constructor to an lvalue of type T then you will be getting an +expression of type TPtr(T). +

+ + You can find the type of an expression with Cil.typeOf. +

+ + You can perform constant folding on expressions using the function +Cil.constFold.
+
type exp = + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+| +Const of constant(*Constant*)
+| +Lval of lval(*Lvalue*)
+| +SizeOf of typ(*sizeof(<type>). Has unsigned int type (ISO 6.5.3.4). This is not + turned into a constant because some transformations might want to + change types*)
+| +SizeOfE of exp(*sizeof(<expression>)*)
+| +SizeOfStr of string(*sizeof(string_literal). We separate this case out because this is the + only instance in which a string literal should not be treated as + having type pointer to character.*)
+| +AlignOf of typ(*This corresponds to the GCC __alignof_. Has unsigned int type*)
+| +AlignOfE of exp
+| +UnOp of unop * exp * typ(*Unary operation. Includes the type of the result.*)
+| +BinOp of binop * exp * exp * typ(*Binary operation. Includes the type of the result. The arithmetic + conversions are made explicit for the arguments.*)
+| +CastE of typ * exp(*Use Cil.mkCast to make casts.*)
+| +AddrOf of lval(*Always use Cil.mkAddrOf to construct one of these. Apply to an + lvalue of type T yields an expression of type TPtr(T)*)
+| +StartOf of lval(*Conversion from an array to a pointer to the beginning of the array. + Given an lval of type TArray(T) produces an expression of type + TPtr(T). In C this operation is implicit, the StartOf operator is + not printed. We have it in CIL because it makes the typing rules + simpler.*)
+ +

+Expressions (Side-effect free)
+
+ +
+Constants.
+
type constant = + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+| +CInt64 of int64 * ikind * string option(*Integer constant. Give the ikind (see ISO9899 6.1.3.2) and the + textual representation, if available. (This allows us to print a + constant as, for example, 0xF instead of 15.) Use Cil.integer or + Cil.kinteger to create these. Watch out for integers that cannot be + represented on 64 bits. OCAML does not give Overflow exceptions.*)
+| +CStr of string
+| +CWStr of int64 list
+| +CChr of char(*Character constant. This has type int, so use charConstToInt + to read the value in case sign-extension is needed.*)
+| +CReal of float * fkind * string option(*Floating point constant. Give the fkind (see ISO 6.4.4.2) and also + the textual representation, if available.*)
+| +CEnum of exp * string * enuminfo(*An enumeration constant with the given value, name, from the given + enuminfo. This is used only if Cil.lowerConstants is true + (default). Use Cil.constFoldVisitor to replace these with integer + constants.*)
+ +
+Literal constants
+
+ +
type unop = + + + + + + + + + + + + + + +
+| +Neg(*Unary minus*)
+| +BNot(*Bitwise complement (~)*)
+| +LNot(*Logical Not (!)*)
+ +
+Unary operators
+
+ +
type binop = + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+| +PlusA(*arithmetic +*)
+| +PlusPI(*pointer + integer*)
+| +IndexPI(*pointer + integer but only when + it arises from an expression + e[i] when e is a pointer and + not an array. This is semantically + the same as PlusPI but CCured uses + this as a hint that the integer is + probably positive.*)
+| +MinusA(*arithmetic -*)
+| +MinusPI(*pointer - integer*)
+| +MinusPP(*pointer - pointer*)
+| +Mult
+| +Div(*/*)
+| +Mod(*%*)
+| +Shiftlt(*shift left*)
+| +Shiftrt(*shift right*)
+| +Lt(*< (arithmetic comparison)*)
+| +Gt(*> (arithmetic comparison)*)
+| +Le(*<= (arithmetic comparison)*)
+| +Ge(*> (arithmetic comparison)*)
+| +Eq(*== (arithmetic comparison)*)
+| +Ne(*!= (arithmetic comparison)*)
+| +BAnd(*bitwise and*)
+| +BXor(*exclusive-or*)
+| +BOr(*inclusive-or*)
+| +LAnd(*logical and. Unlike other + expressions this one does not + always evaluate both operands. If + you want to use these, you must + set Cil.useLogicalOperators.*)
+| +LOr(*logical or. Unlike other + expressions this one does not + always evaluate both operands. If + you want to use these, you must + set Cil.useLogicalOperators.*)
+ +
+Binary operations
+
+ +
+Lvalues. Lvalues are the sublanguage of expressions that can appear at the left of an assignment or as operand to the address-of operator. +In C the syntax for lvalues is not always a good indication of the meaning +of the lvalue. For example the C value +
 
+a[0][1][2]
+
+ might involve 1, 2 or 3 memory reads when used in an expression context, +depending on the declared type of the variable a. If a has type int +[4][4][4] then we have one memory read from somewhere inside the area +that stores the array a. On the other hand if a has type int *** then +the expression really means * ( * ( * (a + 0) + 1) + 2), in which case it is +clear that it involves three separate memory operations. +

+ +An lvalue denotes the contents of a range of memory addresses. This range +is denoted as a host object along with an offset within the object. The +host object can be of two kinds: a local or global variable, or an object +whose address is in a pointer expression. We distinguish the two cases so +that we can tell quickly whether we are accessing some component of a +variable directly or we are accessing a memory location through a pointer. +To make it easy to +tell what an lvalue means CIL represents lvalues as a host object and an +offset (see Cil.lval). The host object (represented as +Cil.lhost) can be a local or global variable or can be the object +pointed-to by a pointer expression. The offset (represented as +Cil.offset) is a sequence of field or array index designators. +

+ + Both the typing rules and the meaning of an lvalue is very precisely +specified in CIL. +

+ + The following are a few useful function for operating on lvalues:

+ +The following equivalences hold 
+Mem(AddrOf(Mem a, aoff)), off   = Mem a, aoff + off 
+Mem(AddrOf(Var v, aoff)), off   = Var v, aoff + off 
+AddrOf (Mem a, NoOffset)        = a                 
+

+
type lval = lhost * offset
+
+An lvalue
+
+ +
type lhost = + + + + + + + + + +
+| +Var of varinfo(*The host is a variable.*)
+| +Mem of exp(*The host is an object of type T when the expression has pointer + TPtr(T).*)
+ +
+The host part of an Cil.lval.
+
+ +
type offset = + + + + + + + + + + + + + + +
+| +NoOffset(*No offset. Can be applied to any lvalue and does + not change either the starting address or the type. + This is used when the lval consists of just a host + or as a terminator in a list of other kinds of + offsets.*)
+| +Field of fieldinfo * offset(*A field offset. Can be applied only to an lvalue + that denotes a structure or a union that contains + the mentioned field. This advances the offset to the + beginning of the mentioned field and changes the + type to the type of the mentioned field.*)
+| +Index of exp * offset(*An array index offset. Can be applied only to an + lvalue that denotes an array. This advances the + starting address of the lval to the beginning of the + mentioned array element and changes the denoted type + to be the type of the array element*)
+ +
+The offset part of an Cil.lval. Each offset can be applied to certain + kinds of lvalues and its effect is that it advances the starting address + of the lvalue and changes the denoted type, essentially focusing to some + smaller lvalue that is contained in the original one.
+
+ +
+Initializers. +A special kind of expressions are those that can appear as initializers for +global variables (initialization of local variables is turned into +assignments). The initializers are represented as type Cil.init. You +can create initializers with Cil.makeZeroInit and you can conveniently +scan compound initializers them with Cil.foldLeftCompound or with Cil.foldLeftCompoundAll.
+
type init = + + + + + + + + + +
+| +SingleInit of exp(*A single initializer*)
+| +CompoundInit of typ * (offset * init) list(*Used only for initializers of structures, unions and arrays. The + offsets are all of the form Field(f, NoOffset) or Index(i, + NoOffset) and specify the field or the index being initialized. For + structures all fields must have an initializer (except the unnamed + bitfields), in the proper order. This is necessary since the offsets + are not printed. For unions there must be exactly one initializer. If + the initializer is not for the first field then a field designator is + printed, so you better be on GCC since MSVC does not understand this. + For arrays, however, we allow you to give only a prefix of the + initializers. You can scan an initializer list with + Cil.foldLeftCompound or with Cil.foldLeftCompoundAll.*)
+ +
+Initializers for global variables.
+
+ +
type initinfo = { + + + + +
+   +mutable init : init option;
+} + +
+We want to be able to update an initializer in a global variable, so we + define it as a mutable field
+
+ +
+Function definitions. +A function definition is always introduced with a GFun constructor at the +top level. All the information about the function is stored into a +Cil.fundec. Some of the information (e.g. its name, type, +storage, attributes) is stored as a Cil.varinfo that is a field of the +fundec. To refer to the function from the expression language you must use +the varinfo. +

+ + The function definition contains, in addition to the body, a list of all the +local variables and separately a list of the formals. Both kind of variables +can be referred to in the body of the function. The formals must also be shared +with the formals that appear in the function type. For that reason, to +manipulate formals you should use the provided functions +Cil.makeFormalVar and Cil.setFormals and Cil.makeFormalVar.
+
type fundec = { + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+   +mutable svar : varinfo;(*Holds the name and type as a variable, so we can refer to it + easily from the program. All references to this function either + in a function call or in a prototype must point to the same + varinfo.*)
+   +mutable sformals : varinfo list;(*Formals. These must be in the same order and with the same + information as the formal information in the type of the function. + Use Cil.setFormals or + Cil.setFunctionType or Cil.makeFormalVar + to set these formals and ensure that they + are reflected in the function type. Do not make copies of these + because the body refers to them.*)
+   +mutable slocals : varinfo list;(*Locals. Does NOT include the sformals. Do not make copies of + these because the body refers to them.*)
+   +mutable smaxid : int;(*Max local id. Starts at 0. Used for + creating the names of new temporary + variables. Updated by + Cil.makeLocalVar and + Cil.makeTempVar. You can also use + Cil.setMaxId to set it after you + have added the formals and locals.*)
+   +mutable sbody : block;(*The function body.*)
+   +mutable smaxstmtid : int option;(*max id of a (reachable) statement + in this function, if we have + computed it. range = 0 ... + (smaxstmtid-1). This is computed by + Cil.computeCFGInfo.*)
+   +mutable sallstmts : stmt list;(*After you call Cil.computeCFGInfo + this field is set to contain all + statements in the function*)
+} + +

+Function definitions.
+
+ +
type block = { + + + + + + + + + +
+   +mutable battrs : attributes;(*Attributes for the block*)
+   +mutable bstmts : stmt list;(*The statements comprising the block*)
+} + +
+A block is a sequence of statements with the control falling through from + one element to the next
+
+ +
+Statements. +CIL statements are the structural elements that make the CFG. They are +represented using the type Cil.stmt. Every +statement has a (possibly empty) list of labels. The +Cil.stmtkind field of a statement indicates what kind of statement it +is. +

+ + Use Cil.mkStmt to make a statement and the fill-in the fields. +

+ +CIL also comes with support for control-flow graphs. The sid field in +stmt can be used to give unique numbers to statements, and the succs +and preds fields can be used to maintain a list of successors and +predecessors for every statement. The CFG information is not computed by +default. Instead you must explicitly use the functions +Cil.prepareCFG and Cil.computeCFGInfo to do it.
+
type stmt = { + + + + + + + + + + + + + + + + + + + + + + + + +
+   +mutable labels : label list;(*Whether the statement starts with some labels, case statements or + default statements.*)
+   +mutable skind : stmtkind;(*The kind of statement*)
+   +mutable sid : int;(*A number (>= 0) that is unique in a function. Filled in only after + the CFG is computed.*)
+   +mutable succs : stmt list;(*The successor statements. They can always be computed from the skind + and the context in which this statement appears. Filled in only after + the CFG is computed.*)
+   +mutable preds : stmt list;(*The inverse of the succs function.*)
+} + +

+Statements.
+
+ +
type label = + + + + + + + + + + + + + + +
+| +Label of string * location * bool(*A real label. If the bool is "true", the label is from the + input source program. If the bool is "false", the label was + created by CIL or some other transformation*)
+| +Case of exp * location(*A case statement. This expression + is lowered into a constant if + Cil.lowerConstants is set to + true.*)
+| +Default of location(*A default statement*)
+ +
+Labels
+
+ +
type stmtkind = + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+| +Instr of instr list(*A group of instructions that do not contain control flow. Control + implicitly falls through.*)
+| +Return of exp option * location(*The return statement. This is a leaf in the CFG.*)
+| +Goto of stmt Pervasives.ref * location(*A goto statement. Appears from actual goto's in the code or from + goto's that have been inserted during elaboration. The reference + points to the statement that is the target of the Goto. This means that + you have to update the reference whenever you replace the target + statement. The target statement MUST have at least a label.*)
+| +Break of location(*A break to the end of the nearest enclosing Loop or Switch*)
+| +Continue of location(*A continue to the start of the nearest enclosing Loop*)
+| +If of exp * block * block * location(*A conditional. Two successors, the "then" and the "else" branches. + Both branches fall-through to the successor of the If statement.*)
+| +Switch of exp * block * stmt list * location(*A switch statement. The statements that implement the cases can be + reached through the provided list. For each such target you can find + among its labels what cases it implements. The statements that + implement the cases are somewhere within the provided block.*)
+| +Loop of block * location * stmt option * stmt option(*A while(1) loop. The termination test is implemented in the body of + a loop using a Break statement. If prepareCFG has been called, + the first stmt option will point to the stmt containing the continue + label for this loop and the second will point to the stmt containing + the break label for this loop.*)
+| +Block of block(*Just a block of statements. Use it as a way to keep some block + attributes local*)
+| +TryFinally of block * block * location
+| +TryExcept of block * (instr list * exp) * block * location
+ +
+The various kinds of control-flow statements statements
+
+ +
+Instructions. + An instruction Cil.instr is a statement that has no local +(intraprocedural) control flow. It can be either an assignment, +function call, or an inline assembly instruction.
+
type instr = + + + + + + + + + + + + + + +
+| +Set of lval * exp * location(*An assignment. The type of the expression is guaranteed to be the same + with that of the lvalue*)
+| +Call of lval option * exp * exp list * location(*A function call with the (optional) result placed in an lval. It is + possible that the returned type of the function is not identical to + that of the lvalue. In that case a cast is printed. The type of the + actual arguments are identical to those of the declared formals. The + number of arguments is the same as that of the declared formals, except + for vararg functions. This construct is also used to encode a call to + "__builtin_va_arg". In this case the second argument (which should be a + type T) is encoded SizeOf(T)*)
+| +Asm of attributes * string list * (string * lval) list
* (string * exp) list * string list * location		(*There are for storing inline assembly. They follow the GCC + specification: +
+  asm [volatile] ("...template..." "..template.."
+                  : "c1" (o1), "c2" (o2), ..., "cN" (oN)
+                  : "d1" (i1), "d2" (i2), ..., "dM" (iM)
+                  : "r1", "r2", ..., "nL" );
+
+

+ +where the parts are +

+

    +
  • volatile (optional): when present, the assembler instruction + cannot be removed, moved, or otherwise optimized
    • +
  • template: a sequence of strings, with %0, %1, %2, etc. in the string to + refer to the input and output expressions. I think they're numbered + consecutively, but the docs don't specify. Each string is printed on + a separate line. This is the only part that is present for MSVC inline + assembly.
    • +
  • "ci" (oi): pairs of constraint-string and output-lval; the + constraint specifies that the register used must have some + property, like being a floating-point register; the constraint + string for outputs also has "=" to indicate it is written, or + "+" to indicate it is both read and written; 'oi' is the + name of a C lvalue (probably a variable name) to be used as + the output destination
    • +
  • "dj" (ij): pairs of constraint and input expression; the constraint + is similar to the "ci"s. the 'ij' is an arbitrary C expression + to be loaded into the corresponding register
    • +
  • "rk": registers to be regarded as "clobbered" by the instruction; + "memory" may be specified for arbitrary memory effects
    • +
+ +an example (from gcc manual): +
+  asm volatile ("movc3 %0,%1,%2"
+                : /* no outputs */
+                : "g" (from), "g" (to), "g" (count)
+                : "r0", "r1", "r2", "r3", "r4", "r5");
+
*)
+ +
+Instructions.
+
+ +
type location = { + + + + + + + + + + + + + + +
+   +line : int;(*The line number. -1 means "do not know"*)
+   +file : string;(*The name of the source file*)
+   +byte : int;(*The byte position in the source file*)
+} + +
+Describes a location in a source file.
+
+ +
type typsig = + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+| +TSArray of typsig * int64 option * attribute list
+| +TSPtr of typsig * attribute list
+| +TSComp of bool * string * attribute list
+| +TSFun of typsig * typsig list * bool * attribute list
+| +TSEnum of string * attribute list
+| +TSBase of typ
+ +
+Type signatures. Two types are identical iff they have identical + signatures. These contain the same information as types but canonicalized. + For example, two function types that are identical except for the name of + the formal arguments are given the same signature. Also, TNamed + constructors are unrolled.
+
+ +
+Lowering Options
+
val lowerConstants : bool Pervasives.ref
+Do lower constants (default true)
+
+
val insertImplicitCasts : bool Pervasives.ref
+Do insert implicit casts (default true)
+
+
type featureDescr = { + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+   +fd_enabled : bool Pervasives.ref;(*The enable flag. Set to default value*)
+   +fd_name : string;(*This is used to construct an option "--doxxx" and "--dontxxx" that + enable and disable the feature*)
+   +fd_description : string;
+   +fd_extraopt : (string * Arg.spec * string) list;(*Additional command line options*)
+   +fd_doit : file -> unit;(*This performs the transformation*)
+   +fd_post_check : bool;
+} + +
+To be able to add/remove features easily, each feature should be package + as an interface with the following interface. These features should be
+
+ +
val compareLoc : location -> location -> int
+Comparison function for locations. +* Compares first by filename, then line, then byte
+
+
+Values for manipulating globals
+
val emptyFunction : string -> fundec
+Make an empty function
+
+
val setFormals : fundec -> varinfo list -> unit
+Update the formals of a fundec and make sure that the function type + has the same information. Will copy the name as well into the type.
+
+
val setFunctionType : fundec -> typ -> unit
+Set the types of arguments and results as given by the function type + passed as the second argument. Will not copy the names from the function + type to the formals
+
+
val setFunctionTypeMakeFormals : fundec -> typ -> unit
+Set the type of the function and make formal arguments for them
+
+
val setMaxId : fundec -> unit
+Update the smaxid after you have populated with locals and formals + (unless you constructed those using Cil.makeLocalVar or + Cil.makeTempVar.
+
+
val dummyFunDec : fundec
+A dummy function declaration handy when you need one as a placeholder. It + contains inside a dummy varinfo.
+
+
val dummyFile : file
+A dummy file
+
+
val saveBinaryFile : file -> string -> unit
+Write a Cil.file in binary form to the filesystem. The file can be + read back in later using Cil.loadBinaryFile, possibly saving parsing + time. The second argument is the name of the file that should be + created.
+
+
val saveBinaryFileChannel : file -> Pervasives.out_channel -> unit
+Write a Cil.file in binary form to the filesystem. The file can be + read back in later using Cil.loadBinaryFile, possibly saving parsing + time. Does not close the channel.
+
+
val loadBinaryFile : string -> file
+Read a Cil.file in binary form from the filesystem. The first + argument is the name of a file previously created by + Cil.saveBinaryFile.
+
+
val getGlobInit : ?main_name:string -> file -> fundec
+Get the global initializer and create one if it does not already exist. + When it creates a global initializer it attempts to place a call to it in + the main function named by the optional argument (default "main")
+
+
val iterGlobals : file -> (global -> unit) -> unit
+Iterate over all globals, including the global initializer
+
+
val foldGlobals : file -> ('a -> global -> 'a) -> 'a -> 'a
+Fold over all globals, including the global initializer
+
+
val mapGlobals : file -> (global -> global) -> unit
+Map over all globals, including the global initializer and change things + in place
+
+
val new_sid : unit -> int
val prepareCFG : fundec -> unit
+Prepare a function for CFG information computation by + Cil.computeCFGInfo. This function converts all Break, Switch, + Default and Continue Cil.stmtkinds and Cil.labels into Ifs + and Gotos, giving the function body a very CFG-like character. This + function modifies its argument in place.
+
+
val computeCFGInfo : fundec -> bool -> unit
+Compute the CFG information for all statements in a fundec and return a + list of the statements. The input fundec cannot have Break, Switch, + Default, or Continue Cil.stmtkinds or Cil.labels. Use + Cil.prepareCFG to transform them away. The second argument should + be true if you wish a global statement number, false if you wish a + local (per-function) statement numbering. The list of statements is set + in the sallstmts field of a fundec. +

+ + NOTE: unless you want the simpler control-flow graph provided by + prepareCFG, or you need the function's smaxstmtid and sallstmt fields + filled in, we recommend you use Cfg.computeFileCFG instead of this + function to compute control-flow information. + Cfg.computeFileCFG is newer and will handle switch, break, and + continue correctly.
+

+
val copyFunction : fundec -> string -> fundec
+Create a deep copy of a function. There should be no sharing between the + copy and the original function
+
+
val pushGlobal : global ->
       types:global list Pervasives.ref ->
       variables:global list Pervasives.ref -> unit
+CIL keeps the types at the beginning of the file and the variables at the + end of the file. This function will take a global and add it to the + corresponding stack. Its operation is actually more complicated because if + the global declares a type that contains references to variables (e.g. in + sizeof in an array length) then it will also add declarations for the + variables to the types stack
+
+
val invalidStmt : stmt
+An empty statement. Used in pretty printing
+
+
val gccBuiltins : (string, typ * typ list * bool) Hashtbl.t
+A list of the GCC built-in functions. Maps the name to the result and + argument types, and whether it is vararg
+
+
val msvcBuiltins : (string, typ * typ list * bool) Hashtbl.t
+A list of the MSVC built-in functions. Maps the name to the result and + argument types, and whether it is vararg
+
+
+Values for manipulating initializers
+
val makeZeroInit : typ -> init
+Make a initializer for zero-ing a data type
+
+
val foldLeftCompound : doinit:(offset -> init -> typ -> 'a -> 'a) ->
       ct:typ -> initl:(offset * init) list -> acc:'a -> 'a
+Fold over the list of initializers in a Compound. doinit is called on + every present initializer, even if it is of compound type. In the case of + arrays there might be missing zero-initializers at the end of the list. + These are not scanned. This is much like List.fold_left except we also + pass the type of the initializer
+
+
val foldLeftCompoundAll : doinit:(offset -> init -> typ -> 'a -> 'a) ->
       ct:typ -> initl:(offset * init) list -> acc:'a -> 'a
+Fold over the list of initializers in a Compound, like + Cil.foldLeftCompound but in the case of an array it scans even missing + zero initializers at the end of the array
+
+
+Values for manipulating types
+
val voidType : typ
+void
+
+
val isVoidType : typ -> bool
val isVoidPtrType : typ -> bool
val intType : typ
+int
+
+
val uintType : typ
+unsigned int
+
+
val longType : typ
+long
+
+
val ulongType : typ
+unsigned long
+
+
val charType : typ
+char
+
+
val charPtrType : typ
+char *
+
+
val wcharKind : ikind Pervasives.ref
+wchar_t (depends on architecture) and is set when you call + Cil.initCIL.
+
+
val wcharType : typ Pervasives.ref
val charConstPtrType : typ
+char const *
+
+
val voidPtrType : typ
+void *
+
+
val intPtrType : typ
+int *
+
+
val uintPtrType : typ
+unsigned int *
+
+
val doubleType : typ
+double
+
+
val upointType : typ Pervasives.ref
val typeOfSizeOf : typ Pervasives.ref
val isSigned : ikind -> bool
+Returns true if and only if the given integer type is signed.
+
+
val mkCompInfo : bool ->
       string ->
       (compinfo ->
        (string * typ * int option * attributes * location) list) ->
       attributes -> compinfo
+Creates a a (potentially recursive) composite type. The arguments are: + (1) a boolean indicating whether it is a struct or a union, (2) the name + (always non-empty), (3) a function that when given a representation of the + structure type constructs the type of the fields recursive type (the first + argument is only useful when some fields need to refer to the type of the + structure itself), and (4) a list of attributes to be associated with the + composite type. The resulting compinfo has the field "cdefined" only if + the list of fields is non-empty.
+
+
val copyCompInfo : compinfo -> string -> compinfo
+Makes a shallow copy of a Cil.compinfo changing the name and the key.
+
+
val missingFieldName : string
+This is a constant used as the name of an unnamed bitfield. These fields + do not participate in initialization and their name is not printed.
+
+
val compFullName : compinfo -> string
+Get the full name of a comp
+
+
val isCompleteType : typ -> bool
+Returns true if this is a complete type. + This means that sizeof(t) makes sense. + Incomplete types are not yet defined + structures and empty arrays.
+
+
val unrollType : typ -> typ
+Unroll a type until it exposes a non + TNamed. Will collect all attributes appearing in TNamed!!!
+
+
val unrollTypeDeep : typ -> typ
+Unroll all the TNamed in a type (even under type constructors such as + TPtr, TFun or TArray. Does not unroll the types of fields in TComp + types. Will collect all attributes
+
+
val separateStorageModifiers : attribute list -> attribute list * attribute list
+Separate out the storage-modifier name attributes
+
+
val isIntegralType : typ -> bool
+True if the argument is an integral type (i.e. integer or enum)
+
+
val isArithmeticType : typ -> bool
+True if the argument is an arithmetic type (i.e. integer, enum or + floating point
+
+
val isPointerType : typ -> bool
+True if the argument is a pointer type
+
+
val isFunctionType : typ -> bool
+True if the argument is a function type
+
+
val argsToList : (string * typ * attributes) list option ->
       (string * typ * attributes) list
+Obtain the argument list ([] if None)
+
+
val isArrayType : typ -> bool
+True if the argument is an array type
+
+
exception LenOfArray
+
+Raised when Cil.lenOfArray fails either because the length is None + or because it is a non-constant expression
+
+
val lenOfArray : exp option -> int
+Call to compute the array length as present in the array type, to an + integer. Raises Cil.LenOfArray if not able to compute the length, such + as when there is no length or the length is not a constant.
+
+
val getCompField : compinfo -> string -> fieldinfo
+Return a named fieldinfo in compinfo, or raise Not_found
+
+
type existsAction = + + + + + + + + + + + + + + +
+| +ExistsTrue
+| +ExistsFalse
+| +ExistsMaybe
+ +
+A datatype to be used in conjunction with existsType
+
+ +
val existsType : (typ -> existsAction) -> typ -> bool
+Scans a type by applying the function on all elements. + When the function returns ExistsTrue, the scan stops with + true. When the function returns ExistsFalse then the current branch is not + scanned anymore. Care is taken to + apply the function only once on each composite type, thus avoiding + circularity. When the function returns ExistsMaybe then the types that + construct the current type are scanned (e.g. the base type for TPtr and + TArray, the type of fields for a TComp, etc).
+
+
val splitFunctionType : typ ->
       typ * (string * typ * attributes) list option * bool *
       attributes
+Given a function type split it into return type, + arguments, is_vararg and attributes. An error is raised if the type is not + a function type +

+Same as Cil.splitFunctionType but takes a varinfo. Prints a nicer + error message if the varinfo is not for a function
+

+
val splitFunctionTypeVI : varinfo ->
       typ * (string * typ * attributes) list option * bool *
       attributes

+Type signatures
+
+Type signatures. Two types are identical iff they have identical + signatures. These contain the same information as types but canonicalized. + For example, two function types that are identical except for the name of + the formal arguments are given the same signature. Also, TNamed + constructors are unrolled. You shoud use Util.equals to compare type + signatures because they might still contain circular structures (through + attributes, and sizeof)
+
val d_typsig : unit -> typsig -> Pretty.doc
+Print a type signature
+
+
val typeSig : typ -> typsig
+Compute a type signature
+
+
val typeSigWithAttrs : ?ignoreSign:bool ->
       (attributes -> attributes) -> typ -> typsig
+Like Cil.typeSig but customize the incorporation of attributes. + Use ~ignoreSign:true to convert all signed integer types to unsigned, + so that signed and unsigned will compare the same.
+
+
val setTypeSigAttrs : attributes -> typsig -> typsig
+Replace the attributes of a signature (only at top level)
+
+
val typeSigAttrs : typsig -> attributes
+Get the top-level attributes of a signature
+
+
+LVALUES
+
val makeVarinfo : bool -> string -> typ -> varinfo
+Make a varinfo. Use this (rarely) to make a raw varinfo. Use other + functions to make locals (Cil.makeLocalVar or Cil.makeFormalVar or + Cil.makeTempVar) and globals (Cil.makeGlobalVar). Note that this + function will assign a new identifier. The first argument specifies + whether the varinfo is for a global.
+
+
val makeFormalVar : fundec -> ?where:string -> string -> typ -> varinfo
+Make a formal variable for a function. Insert it in both the sformals + and the type of the function. You can optionally specify where to insert + this one. If where = "^" then it is inserted first. If where = "$" then + it is inserted last. Otherwise where must be the name of a formal after + which to insert this. By default it is inserted at the end.
+
+
val makeLocalVar : fundec -> ?insert:bool -> string -> typ -> varinfo
+Make a local variable and add it to a function's slocals (only if insert = + true, which is the default). Make sure you know what you are doing if you + set insert=false.
+
+
val makeTempVar : fundec -> ?name:string -> typ -> varinfo
+Make a temporary variable and add it to a function's slocals. The name of + the temporary variable will be generated based on the given name hint so + that to avoid conflicts with other locals.
+
+
val makeGlobalVar : string -> typ -> varinfo
+Make a global variable. Your responsibility to make sure that the name + is unique
+
+
val copyVarinfo : varinfo -> string -> varinfo
+Make a shallow copy of a varinfo and assign a new identifier
+
+
val newVID : unit -> int
+Generate a new variable ID. This will be different than any variable ID + that is generated by Cil.makeLocalVar and friends
+
+
val addOffsetLval : offset -> lval -> lval
+Add an offset at the end of an lvalue. Make sure the type of the lvalue + and the offset are compatible.
+
+
val addOffset : offset -> offset -> offset
+addOffset o1 o2 adds o1 to the end of o2.
+
+
val removeOffsetLval : lval -> lval * offset
+Remove ONE offset from the end of an lvalue. Returns the lvalue with the + trimmed offset and the final offset. If the final offset is NoOffset + then the original lval did not have an offset.
+
+
val removeOffset : offset -> offset * offset
+Remove ONE offset from the end of an offset sequence. Returns the + trimmed offset and the final offset. If the final offset is NoOffset + then the original lval did not have an offset.
+
+
val typeOfLval : lval -> typ
+Compute the type of an lvalue
+
+
val typeOffset : typ -> offset -> typ
+Compute the type of an offset from a base type
+
+
+Values for manipulating expressions
+
val zero : exp
+0
+
+
val one : exp
+1
+
+
val mone : exp
+-1
+
+
val kinteger64 : ikind -> int64 -> exp
+Construct an integer of a given kind, using OCaml's int64 type. If needed + it will truncate the integer to be within the representable range for the + given kind.
+
+
val kinteger : ikind -> int -> exp
+Construct an integer of a given kind. Converts the integer to int64 and + then uses kinteger64. This might truncate the value if you use a kind + that cannot represent the given integer. This can only happen for one of + the Char or Short kinds
+
+
val integer : int -> exp
+Construct an integer of kind IInt. You can use this always since the + OCaml integers are 31 bits and are guaranteed to fit in an IInt
+
+
val isInteger : exp -> int64 option
+True if the given expression is a (possibly cast'ed) + character or an integer constant
+
+
val isConstant : exp -> bool
+True if the expression is a compile-time constant
+
+
val isZero : exp -> bool
+True if the given expression is a (possibly cast'ed) integer or character + constant with value zero
+
+
val charConstToInt : char -> constant
+Given the character c in a (CChr c), sign-extend it to 32 bits. + (This is the official way of interpreting character constants, according to + ISO C 6.4.4.4.10, which says that character constants are chars cast to ints) + Returns CInt64(sign-extened c, IInt, None)
+
+
val constFold : bool -> exp -> exp
+Do constant folding on an expression. If the first argument is true then + will also compute compiler-dependent expressions such as sizeof
+
+
val constFoldBinOp : bool -> binop -> exp -> exp -> typ -> exp
+Do constant folding on a binary operation. The bulk of the work done by + constFold is done here. If the first argument is true then + will also compute compiler-dependent expressions such as sizeof
+
+
val increm : exp -> int -> exp
+Increment an expression. Can be arithmetic or pointer type
+
+
val var : varinfo -> lval
+Makes an lvalue out of a given variable
+
+
val mkAddrOf : lval -> exp
+Make an AddrOf. Given an lvalue of type T will give back an expression of + type ptr(T). It optimizes somewhat expressions like "& v" and "& v0"
+
+
val mkAddrOrStartOf : lval -> exp
+Like mkAddrOf except if the type of lval is an array then it uses + StartOf. This is the right operation for getting a pointer to the start + of the storage denoted by lval.
+
+
val mkMem : addr:exp -> off:offset -> lval
+Make a Mem, while optimizing AddrOf. The type of the addr must be + TPtr(t) and the type of the resulting lval is t. Note that in CIL the + implicit conversion between an array and the pointer to the first + element does not apply. You must do the conversion yourself using + StartOf
+
+
val mkString : string -> exp
+Make an expression that is a string constant (of pointer type)
+
+
val mkCastT : e:exp -> oldt:typ -> newt:typ -> exp
+Construct a cast when having the old type of the expression. If the new + type is the same as the old type, then no cast is added.
+
+
val mkCast : e:exp -> newt:typ -> exp
+Like Cil.mkCastT but uses typeOf to get oldt
+
+
val stripCasts : exp -> exp
+Removes casts from this expression, but ignores casts within + other expression constructs. So we delete the (A) and (B) casts from + "(A)(B)(x + (C)y)", but leave the (C) cast.
+
+
val typeOf : exp -> typ
+Compute the type of an expression
+
+
val parseInt : string -> exp
+Convert a string representing a C integer literal to an expression. + Handles the prefixes 0x and 0 and the suffixes L, U, UL, LL, ULL
+
+
+Values for manipulating statements
+
val mkStmt : stmtkind -> stmt
+Construct a statement, given its kind. Initialize the sid field to -1, + and labels, succs and preds to the empty list
+
+
val mkBlock : stmt list -> block
+Construct a block with no attributes, given a list of statements
+
+
val mkStmtOneInstr : instr -> stmt
+Construct a statement consisting of just one instruction
+
+
val compactStmts : stmt list -> stmt list
+Try to compress statements so as to get maximal basic blocks
+
+
val mkEmptyStmt : unit -> stmt
+Returns an empty statement (of kind Instr)
+
+
val dummyInstr : instr
+A instr to serve as a placeholder
+
+
val dummyStmt : stmt
+A statement consisting of just dummyInstr
+
+
val mkWhile : guard:exp -> body:stmt list -> stmt list
+Make a while loop. Can contain Break or Continue
+
+
val mkForIncr : iter:varinfo ->
       first:exp ->
       stopat:exp -> incr:exp -> body:stmt list -> stmt list
+Make a for loop for(i=start; i<past; i += incr) { ... }. The body + can contain Break but not Continue. Can be used with i a pointer + or an integer. Start and done must have the same type but incr + must be an integer
+
+
val mkFor : start:stmt list ->
       guard:exp -> next:stmt list -> body:stmt list -> stmt list
+Make a for loop for(start; guard; next) { ... }. The body can + contain Break but not Continue !!!
+
+
+Values for manipulating attributes
+
type attributeClass = + + + + + + + + + + + + + + +
+| +AttrName of bool(*Attribute of a name. If argument is true and we are on MSVC then + the attribute is printed using __declspec as part of the storage + specifier*)
+| +AttrFunType of bool(*Attribute of a function type. If argument is true and we are on + MSVC then the attribute is printed just before the function name*)
+| +AttrType(*Attribute of a type*)
+ +
+Various classes of attributes
+
+ +
val attributeHash : (string, attributeClass) Hashtbl.t
+This table contains the mapping of predefined attributes to classes. + Extend this table with more attributes as you need. This table is used to + determine how to associate attributes with names or types
+
+
val partitionAttributes : default:attributeClass ->
       attributes ->
       attribute list * attribute list * attribute list
+Partition the attributes into classes:name attributes, function type, + and type attributes
+
+
val addAttribute : attribute -> attributes -> attributes
+Add an attribute. Maintains the attributes in sorted order of the second + argument
+
+
val addAttributes : attribute list -> attributes -> attributes
+Add a list of attributes. Maintains the attributes in sorted order. The + second argument must be sorted, but not necessarily the first
+
+
val dropAttribute : string -> attributes -> attributes
+Remove all attributes with the given name. Maintains the attributes in + sorted order.
+
+
val dropAttributes : string list -> attributes -> attributes
+Remove all attributes with names appearing in the string list. + Maintains the attributes in sorted order
+
+
val filterAttributes : string -> attributes -> attributes
+Retains attributes with the given name
+
+
val hasAttribute : string -> attributes -> bool
+True if the named attribute appears in the attribute list. The list of + attributes must be sorted.
+
+
val typeAttrs : typ -> attribute list
+Returns all the attributes contained in a type. This requires a traversal + of the type structure, in case of composite, enumeration and named types
+
+
val setTypeAttrs : typ -> attributes -> typ
val typeAddAttributes : attribute list -> typ -> typ
+Add some attributes to a type
+
+
val typeRemoveAttributes : string list -> typ -> typ
+Remove all attributes with the given names from a type. Note that this + does not remove attributes from typedef and tag definitions, just from + their uses
+
+
+The visitor
+
type 'a visitAction = + + + + + + + + + + + + + + + + + + + +
+| +SkipChildren(*Do not visit the children. Return + the node as it is.*)
+| +DoChildren(*Continue with the children of this + node. Rebuild the node on return + if any of the children changes + (use == test)*)
+| +ChangeTo of 'a(*Replace the expression with the + given one*)
+| +ChangeDoChildrenPost of 'a * ('a -> 'a)(*First consider that the entire + exp is replaced by the first + parameter. Then continue with + the children. On return rebuild + the node if any of the children + has changed and then apply the + function on the node*)
+ +
+Different visiting actions. 'a will be instantiated with exp, instr, + etc.
+
+ +
class type cilVisitor = object .. end
+A visitor interface for traversing CIL trees. +
+
class nopCilVisitor : cilVisitor
+Default Visitor. +
+
val visitCilFile : cilVisitor -> file -> unit
+Visit a file. This will will re-cons all globals TWICE (so that it is + tail-recursive). Use Cil.visitCilFileSameGlobals if your visitor will + not change the list of globals.
+
+
val visitCilFileSameGlobals : cilVisitor -> file -> unit
+A visitor for the whole file that does not change the globals (but maybe + changes things inside the globals). Use this function instead of + Cil.visitCilFile whenever appropriate because it is more efficient for + long files.
+
+
val visitCilGlobal : cilVisitor -> global -> global list
+Visit a global
+
+
val visitCilFunction : cilVisitor -> fundec -> fundec
+Visit a function definition
+
+
val visitCilExpr : cilVisitor -> exp -> exp
val visitCilLval : cilVisitor -> lval -> lval
+Visit an lvalue
+
+
val visitCilOffset : cilVisitor -> offset -> offset
+Visit an lvalue or recursive offset
+
+
val visitCilInitOffset : cilVisitor -> offset -> offset
+Visit an initializer offset
+
+
val visitCilInstr : cilVisitor -> instr -> instr list
+Visit an instruction
+
+
val visitCilStmt : cilVisitor -> stmt -> stmt
+Visit a statement
+
+
val visitCilBlock : cilVisitor -> block -> block
+Visit a block
+
+
val visitCilType : cilVisitor -> typ -> typ
+Visit a type
+
+
val visitCilVarDecl : cilVisitor -> varinfo -> varinfo
+Visit a variable declaration
+
+
val visitCilInit : cilVisitor -> init -> init
+Visit an initializer
+
+
val visitCilAttributes : cilVisitor -> attribute list -> attribute list
+Visit a list of attributes
+
+
+Utility functions
+
val msvcMode : bool Pervasives.ref
+Whether the pretty printer should print output for the MS VC compiler. + Default is GCC. After you set this function you should call Cil.initCIL.
+
+
val useLogicalOperators : bool Pervasives.ref
+Whether to use the logical operands LAnd and LOr. By default, do not use + them because they are unlike other expressions and do not evaluate both of + their operands
+
+
val constFoldVisitor : bool -> cilVisitor
+A visitor that does constant folding. Pass as argument whether you want + machine specific simplifications to be done, or not.
+
+
type lineDirectiveStyle = + + + + + + + + + + + + + + +
+| +LineComment
+| +LinePreprocessorInput
+| +LinePreprocessorOutput
+ +
+Styles of printing line directives
+
+ +
val lineDirectiveStyle : lineDirectiveStyle option Pervasives.ref
+How to print line directives
+
+
val print_CIL_Input : bool Pervasives.ref
+Whether we print something that will only be used as input to our own + parser. In that case we are a bit more liberal in what we print
+
+
val printCilAsIs : bool Pervasives.ref
+Whether to print the CIL as they are, without trying to be smart and + print nicer code. Normally this is false, in which case the pretty + printer will turn the while(1) loops of CIL into nicer loops, will not + print empty "else" blocks, etc. These is one case howewer in which if you + turn this on you will get code that does not compile: if you use varargs + the __builtin_va_arg function will be printed in its internal form.
+
+
val lineLength : int Pervasives.ref
+The length used when wrapping output lines. Setting this variable to + a large integer will prevent wrapping and make #line directives more + accurate.
+
+
val forgcc : string -> string
+Return the string 's' if we're printing output for gcc, suppres + it if we're printing for CIL to parse back in. the purpose is to + hide things from gcc that it complains about, but still be able + to do lossless transformations when CIL is the consumer
+
+
+Debugging support
+
val currentLoc : location Pervasives.ref
+A reference to the current location. If you are careful to set this to + the current location then you can use some built-in logging functions that + will print the location.
+
+
val currentGlobal : global Pervasives.ref
+A reference to the current global being visited
+
+
+CIL has a fairly easy to use mechanism for printing error messages. This + mechanism is built on top of the pretty-printer mechanism (see + Pretty.doc) and the error-message modules (see Errormsg.error). +

+ + Here is a typical example for printing a log message: 

+ignore (Errormsg.log "Expression %a is not positive (at %s:%i)\n"
+                        d_exp e loc.file loc.line)
+
+

+ + and here is an example of how you print a fatal error message that stop the + execution: 

+Errormsg.s (Errormsg.bug "Why am I here?")
+
+

+ + Notice that you can use C format strings with some extension. The most +useful extension is "%a" that means to consumer the next two argument from +the argument list and to apply the first to unit and then to the second +and to print the resulting Pretty.doc. For each major type in CIL there is +a corresponding function that pretty-prints an element of that type:
+

val d_loc : unit -> location -> Pretty.doc
+Pretty-print a location
+
+
val d_thisloc : unit -> Pretty.doc
+Pretty-print the Cil.currentLoc
+
+
val d_ikind : unit -> ikind -> Pretty.doc
+Pretty-print an integer of a given kind
+
+
val d_fkind : unit -> fkind -> Pretty.doc
+Pretty-print a floating-point kind
+
+
val d_storage : unit -> storage -> Pretty.doc
+Pretty-print storage-class information
+
+
val d_const : unit -> constant -> Pretty.doc
+Pretty-print a constant
+
+
val derefStarLevel : int
val indexLevel : int
val arrowLevel : int
val addrOfLevel : int
val additiveLevel : int
val comparativeLevel : int
val bitwiseLevel : int
val getParenthLevel : exp -> int
+Parentheses level. An expression "a op b" is printed parenthesized if its + parentheses level is >= that that of its context. Identifiers have the + lowest level and weakly binding operators (e.g. |) have the largest level. + The correctness criterion is that a smaller level MUST correspond to a + stronger precedence!
+
+
class type cilPrinter = object .. end
+A printer interface for CIL trees. +
+
class defaultCilPrinterClass : cilPrinter
val defaultCilPrinter : cilPrinter
class plainCilPrinterClass : cilPrinter
+These are pretty-printers that will show you more details on the internal + CIL representation, without trying hard to make it look like C +
+
val plainCilPrinter : cilPrinter
val printerForMaincil : cilPrinter Pervasives.ref
val printType : cilPrinter -> unit -> typ -> Pretty.doc
+Print a type given a pretty printer
+
+
val printExp : cilPrinter -> unit -> exp -> Pretty.doc
+Print an expression given a pretty printer
+
+
val printLval : cilPrinter -> unit -> lval -> Pretty.doc
+Print an lvalue given a pretty printer
+
+
val printGlobal : cilPrinter -> unit -> global -> Pretty.doc
+Print a global given a pretty printer
+
+
val printAttr : cilPrinter -> unit -> attribute -> Pretty.doc
+Print an attribute given a pretty printer
+
+
val printAttrs : cilPrinter -> unit -> attributes -> Pretty.doc
+Print a set of attributes given a pretty printer
+
+
val printInstr : cilPrinter -> unit -> instr -> Pretty.doc
+Print an instruction given a pretty printer
+
+
val printStmt : cilPrinter -> unit -> stmt -> Pretty.doc
+Print a statement given a pretty printer. This can take very long + (or even overflow the stack) for huge statements. Use Cil.dumpStmt + instead.
+
+
val printBlock : cilPrinter -> unit -> block -> Pretty.doc
+Print a block given a pretty printer. This can take very long + (or even overflow the stack) for huge block. Use Cil.dumpBlock + instead.
+
+
val dumpStmt : cilPrinter -> Pervasives.out_channel -> int -> stmt -> unit
+Dump a statement to a file using a given indentation. Use this instead of + Cil.printStmt whenever possible.
+
+
val dumpBlock : cilPrinter -> Pervasives.out_channel -> int -> block -> unit
+Dump a block to a file using a given indentation. Use this instead of + Cil.printBlock whenever possible.
+
+
val printInit : cilPrinter -> unit -> init -> Pretty.doc
+Print an initializer given a pretty printer. This can take very long + (or even overflow the stack) for huge initializers. Use Cil.dumpInit + instead.
+
+
val dumpInit : cilPrinter -> Pervasives.out_channel -> int -> init -> unit
+Dump an initializer to a file using a given indentation. Use this instead of + Cil.printInit whenever possible.
+
+
val d_type : unit -> typ -> Pretty.doc
+Pretty-print a type using Cil.defaultCilPrinter
+
+
val d_exp : unit -> exp -> Pretty.doc
+Pretty-print an expression using Cil.defaultCilPrinter
+
+
val d_lval : unit -> lval -> Pretty.doc
+Pretty-print an lvalue using Cil.defaultCilPrinter
+
+
val d_offset : Pretty.doc -> unit -> offset -> Pretty.doc
+Pretty-print an offset using Cil.defaultCilPrinter, given the pretty + printing for the base.
+
+
val d_init : unit -> init -> Pretty.doc
+Pretty-print an initializer using Cil.defaultCilPrinter. This can be + extremely slow (or even overflow the stack) for huge initializers. Use + Cil.dumpInit instead.
+
+
val d_binop : unit -> binop -> Pretty.doc
+Pretty-print a binary operator
+
+
val d_unop : unit -> unop -> Pretty.doc
+Pretty-print a unary operator
+
+
val d_attr : unit -> attribute -> Pretty.doc
+Pretty-print an attribute using Cil.defaultCilPrinter
+
+
val d_attrparam : unit -> attrparam -> Pretty.doc
+Pretty-print an argument of an attribute using Cil.defaultCilPrinter
+
+
val d_attrlist : unit -> attributes -> Pretty.doc
+Pretty-print a list of attributes using Cil.defaultCilPrinter
+
+
val d_instr : unit -> instr -> Pretty.doc
+Pretty-print an instruction using Cil.defaultCilPrinter
+
+
val d_label : unit -> label -> Pretty.doc
+Pretty-print a label using Cil.defaultCilPrinter
+
+
val d_stmt : unit -> stmt -> Pretty.doc
+Pretty-print a statement using Cil.defaultCilPrinter. This can be + extremely slow (or even overflow the stack) for huge statements. Use + Cil.dumpStmt instead.
+
+
val d_block : unit -> block -> Pretty.doc
+Pretty-print a block using Cil.defaultCilPrinter. This can be + extremely slow (or even overflow the stack) for huge blocks. Use + Cil.dumpBlock instead.
+
+
val d_global : unit -> global -> Pretty.doc
+Pretty-print the internal representation of a global using + Cil.defaultCilPrinter. This can be extremely slow (or even overflow the + stack) for huge globals (such as arrays with lots of initializers). Use + Cil.dumpGlobal instead.
+
+
val dn_exp : unit -> exp -> Pretty.doc
+Versions of the above pretty printers, that don't print #line directives
+
+
val dn_lval : unit -> lval -> Pretty.doc
val dn_init : unit -> init -> Pretty.doc
val dn_type : unit -> typ -> Pretty.doc
val dn_global : unit -> global -> Pretty.doc
val dn_attrlist : unit -> attributes -> Pretty.doc
val dn_attr : unit -> attribute -> Pretty.doc
val dn_attrparam : unit -> attrparam -> Pretty.doc
val dn_stmt : unit -> stmt -> Pretty.doc
val dn_instr : unit -> instr -> Pretty.doc
val d_shortglobal : unit -> global -> Pretty.doc
+Pretty-print a short description of the global. This is useful for error + messages
+
+
val dumpGlobal : cilPrinter -> Pervasives.out_channel -> global -> unit
+Pretty-print a global. Here you give the channel where the printout + should be sent.
+
+
val dumpFile : cilPrinter -> Pervasives.out_channel -> string -> file -> unit
+Pretty-print an entire file. Here you give the channel where the printout + should be sent.
+
+
val bug : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+Like Errormsg.bug except that Cil.currentLoc is also printed
+
+
val unimp : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+Like Errormsg.unimp except that Cil.currentLocis also printed
+
+
val error : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+Like Errormsg.error except that Cil.currentLoc is also printed
+
+
val errorLoc : location -> ('a, unit, Pretty.doc) Pervasives.format -> 'a
+Like Cil.error except that it explicitly takes a location argument, + instead of using the Cil.currentLoc
+
+
val warn : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+Like Errormsg.warn except that Cil.currentLoc is also printed
+
+
val warnOpt : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+Like Errormsg.warnOpt except that Cil.currentLoc is also printed. + This warning is printed only of Errormsg.warnFlag is set.
+
+
val warnContext : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+Like Errormsg.warn except that Cil.currentLoc and context + is also printed
+
+
val warnContextOpt : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+Like Errormsg.warn except that Cil.currentLoc and context is also + printed. This warning is printed only of Errormsg.warnFlag is set.
+
+
val warnLoc : location -> ('a, unit, Pretty.doc) Pervasives.format -> 'a
+Like Cil.warn except that it explicitly takes a location argument, + instead of using the Cil.currentLoc
+
+
+Sometimes you do not want to see the syntactic sugar that the above + pretty-printing functions add. In that case you can use the following + pretty-printing functions. But note that the output of these functions is + not valid C
+
val d_plainexp : unit -> exp -> Pretty.doc
+Pretty-print the internal representation of an expression
+
+
val d_plaininit : unit -> init -> Pretty.doc
+Pretty-print the internal representation of an integer
+
+
val d_plainlval : unit -> lval -> Pretty.doc
+Pretty-print the internal representation of an lvalue
+
+
+Pretty-print the internal representation of an lvalue offset +val d_plainoffset: unit -> offset -> Pretty.doc
+
val d_plaintype : unit -> typ -> Pretty.doc
+Pretty-print the internal representation of a type
+
+
+ALPHA conversion has been moved to the Alpha module.
+
val uniqueVarNames : file -> unit
+Assign unique names to local variables. This might be necessary after you + transformed the code and added or renamed some new variables. Names are + not used by CIL internally, but once you print the file out the compiler + downstream might be confused. You might + have added a new global that happens to have the same name as a local in + some function. Rename the local to ensure that there would never be + confusioin. Or, viceversa, you might have added a local with a name that + conflicts with a global
+
+
+Optimization Passes
+
val peepHole2 : (instr * instr -> instr list option) -> stmt list -> unit
+A peephole optimizer that processes two adjacent statements and possibly + replaces them both. If some replacement happens, then the new statements + are themselves subject to optimization
+
+
val peepHole1 : (instr -> instr list option) -> stmt list -> unit
+Similar to peepHole2 except that the optimization window consists of + one statement, not two
+
+
+Machine dependency
+
exception SizeOfError of string * typ
+
+Raised when one of the bitsSizeOf functions cannot compute the size of a + type. This can happen because the type contains array-length expressions + that we don't know how to compute or because it is a type whose size is + not defined (e.g. TFun or an undefined compinfo). The string is an + explanation of the error
+
+
val bitsSizeOf : typ -> int
+The size of a type, in bits. Trailing padding is added for structs and + arrays. Raises Cil.SizeOfError when it cannot compute the size. This + function is architecture dependent, so you should only call this after you + call Cil.initCIL. Remember that on GCC sizeof(void) is 1!
+
+
val sizeOf : typ -> exp
val alignOf_int : typ -> int
+The minimum alignment (in bytes) for a type. This function is + architecture dependent, so you should only call this after you call + Cil.initCIL.
+
+
val bitsOffset : typ -> offset -> int * int
+Give a type of a base and an offset, returns the number of bits from the + base address and the width (also expressed in bits) for the subobject + denoted by the offset. Raises Cil.SizeOfError when it cannot compute + the size. This function is architecture dependent, so you should only call + this after you call Cil.initCIL.
+
+
val char_is_unsigned : bool Pervasives.ref
+Whether "char" is unsigned. Set after you call Cil.initCIL
+
+
val little_endian : bool Pervasives.ref
+Whether the machine is little endian. Set after you call Cil.initCIL
+
+
val underscore_name : bool Pervasives.ref
+Whether the compiler generates assembly labels by prepending "_" to the + identifier. That is, will function foo() have the label "foo", or "_foo"? + Set after you call Cil.initCIL
+
+
val locUnknown : location
+Represents a location that cannot be determined
+
+
val get_instrLoc : instr -> location
+Return the location of an instruction
+
+
val get_globalLoc : global -> location
+Return the location of a global, or locUnknown
+
+
val get_stmtLoc : stmtkind -> location
+Return the location of a statement, or locUnknown
+
+
val dExp : Pretty.doc -> exp
+Generate an Cil.exp to be used in case of errors.
+
+
val dInstr : Pretty.doc -> location -> instr
+Generate an Cil.instr to be used in case of errors.
+
+
val dGlobal : Pretty.doc -> location -> global
+Generate a Cil.global to be used in case of errors.
+
+
val mapNoCopy : ('a -> 'a) -> 'a list -> 'a list
+Like map but try not to make a copy of the list
+
+
val mapNoCopyList : ('a -> 'a list) -> 'a list -> 'a list
+Like map but each call can return a list. Try not to make a copy of the + list
+
+
val startsWith : string -> string -> bool
+sm: return true if the first is a prefix of the second string
+
+
+An Interpreter for constructing CIL constructs
+
type formatArg = + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
+| +Fe of exp
+| +Feo of exp option(*For array lengths*)
+| +Fu of unop
+| +Fb of binop
+| +Fk of ikind
+| +FE of exp list(*For arguments in a function call*)
+| +Ff of (string * typ * attributes)(*For a formal argument*)
+| +FF of (string * typ * attributes) list(*For formal argument lists*)
+| +Fva of bool(*For the ellipsis in a function type*)
+| +Fv of varinfo
+| +Fl of lval
+| +Flo of lval option
+| +Fo of offset
+| +Fc of compinfo
+| +Fi of instr
+| +FI of instr list
+| +Ft of typ
+| +Fd of int
+| +Fg of string
+| +Fs of stmt
+| +FS of stmt list
+| +FA of attributes
+| +Fp of attrparam
+| +FP of attrparam list
+| +FX of string
+ +
+The type of argument for the interpreter
+
+ +
val d_formatarg : unit -> formatArg -> Pretty.doc
+Pretty-prints a format arg
+
+
val lowerConstants : bool Pervasives.ref
+Do lower constant expressions into constants (default true)
+
+ \ No newline at end of file diff --git a/cil/doc/api/Cil.nopCilVisitor.html b/cil/doc/api/Cil.nopCilVisitor.html new file mode 100644 index 0000000..868e79d --- /dev/null +++ b/cil/doc/api/Cil.nopCilVisitor.html @@ -0,0 +1,35 @@ + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cil.nopCilVisitor + + +
 Up + Next +
+

Class Cil.nopCilVisitor

+
+
class nopCilVisitor : cilVisitor
Default Visitor. Traverses the CIL tree without modifying anything
+
+ \ No newline at end of file diff --git a/cil/doc/api/Cil.plainCilPrinterClass.html b/cil/doc/api/Cil.plainCilPrinterClass.html new file mode 100644 index 0000000..0d5fca5 --- /dev/null +++ b/cil/doc/api/Cil.plainCilPrinterClass.html @@ -0,0 +1,36 @@ + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cil.plainCilPrinterClass + + +
Previous + Up + 
+

Class Cil.plainCilPrinterClass

+
+
class plainCilPrinterClass : cilPrinter
These are pretty-printers that will show you more details on the internal + CIL representation, without trying hard to make it look like C
+
+ \ No newline at end of file diff --git a/cil/doc/api/Cillower.html b/cil/doc/api/Cillower.html new file mode 100644 index 0000000..d8fa8dd --- /dev/null +++ b/cil/doc/api/Cillower.html @@ -0,0 +1,40 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cillower + + +
Previous + Up + Next +
+

Module Cillower

+
+
module Cillower: sig .. end
A number of lowering passes over CIL
+
+
val lowerEnumVisitor : Cil.cilVisitor
+Replace enumeration constants with integer constants
+
+ \ No newline at end of file diff --git a/cil/doc/api/Clist.html b/cil/doc/api/Clist.html new file mode 100644 index 0000000..27f373e --- /dev/null +++ b/cil/doc/api/Clist.html @@ -0,0 +1,118 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Clist + + +
Previous + Up + Next +
+

Module Clist

+
+
module Clist: sig .. end
Utilities for managing "concatenable lists" (clists). We often need to + concatenate sequences, and using lists for this purpose is expensive. This + module provides routines to manage such lists more efficiently. In this + model, we never do cons or append explicitly. Instead we maintain + the elements of the list in a special data structure. Routines are provided + to convert to/from ordinary lists, and carry out common list operations.
+
+
type 'a clist = + + + + + + + + + + + + + + + + + + + +
+| +CList of 'a list(*The only representation for the empty + list. Try to use sparingly.*)
+| +CConsL of 'a * 'a clist(*Do not use this a lot because scanning + it is not tail recursive*)
+| +CConsR of 'a clist * 'a
+| +CSeq of 'a clist * 'a clist(*We concatenate only two of them at this + time. Neither is the empty clist. To be + sure always use append to make these*)
+ +
+The clist datatype. A clist can be an ordinary list, or a clist preceded + or followed by an element, or two clists implicitly appended together
+
+ +
val toList : 'a clist -> 'a list
+Convert a clist to an ordinary list
+
+
val fromList : 'a list -> 'a clist
+Convert an ordinary list to a clist
+
+
val single : 'a -> 'a clist
+Create a clist containing one element
+
+
val empty : 'a clist
+The empty clist
+
+
val append : 'a clist -> 'a clist -> 'a clist
+Append two clists
+
+
val checkBeforeAppend : 'a clist -> 'a clist -> bool
+A useful check to assert before an append. It checks that the two lists + are not identically the same (Except if they are both empty)
+
+
val length : 'a clist -> int
+Find the length of a clist
+
+
val map : ('a -> 'b) -> 'a clist -> 'b clist
+Map a function over a clist. Returns another clist
+
+
val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b clist -> 'a
+A version of fold_left that works on clists
+
+
val iter : ('a -> unit) -> 'a clist -> unit
+A version of iter that works on clists
+
+
val rev : ('a -> 'a) -> 'a clist -> 'a clist
+Reverse a clist. The first function reverses an element.
+
+
val docCList : Pretty.doc -> ('a -> Pretty.doc) -> unit -> 'a clist -> Pretty.doc
+A document for printing a clist (similar to docList)
+
+ \ No newline at end of file diff --git a/cil/doc/api/Dataflow.BackwardsDataFlow.html b/cil/doc/api/Dataflow.BackwardsDataFlow.html new file mode 100644 index 0000000..782d318 --- /dev/null +++ b/cil/doc/api/Dataflow.BackwardsDataFlow.html @@ -0,0 +1,54 @@ + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Dataflow.BackwardsDataFlow + + +
Previous + Up + 
+

Functor Dataflow.BackwardsDataFlow

+
+
module BackwardsDataFlow: 
functor (T : BackwardsTransfer) -> sig .. end
+ + + + +
Parameters: + + + + +
+T:BackwardsTransfer +
+
+
+
val compute : Cil.stmt list -> unit
+Fill in the T.stmtStartData, given a number of initial statements to + start from (the sinks for the backwards data flow). All of the statements + (not just the initial ones!) must have some entry in T.stmtStartData + (i.e., the initial data should not be bottom)
+
+ \ No newline at end of file diff --git a/cil/doc/api/Dataflow.BackwardsTransfer.html b/cil/doc/api/Dataflow.BackwardsTransfer.html new file mode 100644 index 0000000..0ff812d --- /dev/null +++ b/cil/doc/api/Dataflow.BackwardsTransfer.html @@ -0,0 +1,83 @@ + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Dataflow.BackwardsTransfer + + +
Previous + Up + 
+

Module type Dataflow.BackwardsTransfer

+
+
module type BackwardsTransfer = sig .. end
+
val name : string
+For debugging purposes, the name of the analysis
+
+
val debug : bool Pervasives.ref
+Whether to turn on debugging
+
+
type t
+
+The type of the data we compute for each block start. In many + presentations of backwards data flow analysis we maintain the + data at the block end. This is not easy to do with JVML because + a block has many exceptional ends. So we maintain the data for + the statement start.
+
+ +
val pretty : unit -> t -> Pretty.doc
+Pretty-print the state
+
+
val stmtStartData : t Inthash.t
+For each block id, the data at the start. This data structure must be + initialized with the initial data for each block
+
+
val combineStmtStartData : Cil.stmt ->
       old:t ->
       t -> t option
+When the analysis reaches the start of a block, combine the old data + with the one we have just computed. Return None if the combination is + the same as the old data, otherwise return the combination. In the + latter case, the predecessors of the statement are put on the working + list.
+
+
val combineSuccessors : t ->
       t -> t
+Take the data from two successors and combine it
+
+
val doStmt : Cil.stmt -> t Dataflow.action
+The (backwards) transfer function for a branch. The Cil.currentLoc is + set before calling this. If it returns None, then we have some default + handling. Otherwise, the returned data is the data before the branch + (not considering the exception handlers)
+
+
val doInstr : Cil.instr ->
       t -> t Dataflow.action
+The (backwards) transfer function for an instruction. The + Cil.currentLoc is set before calling this. If it returns None, then we + have some default handling. Otherwise, the returned data is the data + before the branch (not considering the exception handlers)
+
+
val filterStmt : Cil.stmt -> Cil.stmt -> bool
+Whether to put this predecessor block in the worklist. We give the + predecessor and the block whose predecessor we are (and whose data has + changed)
+
+ \ No newline at end of file diff --git a/cil/doc/api/Dataflow.ForwardsDataFlow.html b/cil/doc/api/Dataflow.ForwardsDataFlow.html new file mode 100644 index 0000000..760dc2b --- /dev/null +++ b/cil/doc/api/Dataflow.ForwardsDataFlow.html @@ -0,0 +1,53 @@ + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Dataflow.ForwardsDataFlow + + +
 Up + Next +
+

Functor Dataflow.ForwardsDataFlow

+
+
module ForwardsDataFlow: 
functor (T : ForwardsTransfer) -> sig .. end
+ + + + +
Parameters: + + + + +
+T:ForwardsTransfer +
+
+
+
val compute : Cil.stmt list -> unit
+Fill in the T.stmtStartData, given a number of initial statements to + start from. All of the initial statements must have some entry in + T.stmtStartData (i.e., the initial data should not be bottom)
+
+ \ No newline at end of file diff --git a/cil/doc/api/Dataflow.ForwardsTransfer.html b/cil/doc/api/Dataflow.ForwardsTransfer.html new file mode 100644 index 0000000..dbefaa0 --- /dev/null +++ b/cil/doc/api/Dataflow.ForwardsTransfer.html @@ -0,0 +1,88 @@ + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Dataflow.ForwardsTransfer + + +
 Up + Next +
+

Module type Dataflow.ForwardsTransfer

+
+
module type ForwardsTransfer = sig .. end
+
val name : string
+For debugging purposes, the name of the analysis
+
+
val debug : bool Pervasives.ref
+Whether to turn on debugging
+
+
type t
+
+The type of the data we compute for each block start. May be + imperative.
+
+ +
val copy : t -> t
+Make a deep copy of the data
+
+
val stmtStartData : t Inthash.t
+For each statement id, the data at the start. Not found in the hash + table means nothing is known about the state at this point. At the end + of the analysis this means that the block is not reachable.
+
+
val pretty : unit -> t -> Pretty.doc
+Pretty-print the state
+
+
val computeFirstPredecessor : Cil.stmt -> t -> t
+Give the first value for a predecessors, compute the value to be set + for the block
+
+
val combinePredecessors : Cil.stmt ->
       old:t ->
       t -> t option
+Take some old data for the start of a statement, and some new data for + the same point. Return None if the combination is identical to the old + data. Otherwise, compute the combination, and return it.
+
+
val doInstr : Cil.instr ->
       t -> t Dataflow.action
+The (forwards) transfer function for an instruction. The + Cil.currentLoc is set before calling this. The default action is to + continue with the state unchanged.
+
+
val doStmt : Cil.stmt ->
       t ->
       t Dataflow.stmtaction
+The (forwards) transfer function for a statement. The Cil.currentLoc + is set before calling this. The default action is to do the instructions + in this statement, if applicable, and continue with the successors.
+
+
val doGuard : Cil.exp ->
       t ->
       t Dataflow.guardaction
+Generate the successor to an If statement assuming the given expression + is nonzero. Analyses that don't need guard information can return + GDefault; this is equivalent to returning GUse of the input. + A return value of GUnreachable indicates that this half of the branch + will not be taken and should not be explored. This will be called + twice per If, once for "then" and once for "else".
+
+
val filterStmt : Cil.stmt -> bool
+Whether to put this statement in the worklist. This is called when a + block would normally be put in the worklist.
+
+ \ No newline at end of file diff --git a/cil/doc/api/Dataflow.html b/cil/doc/api/Dataflow.html new file mode 100644 index 0000000..9f744ea --- /dev/null +++ b/cil/doc/api/Dataflow.html @@ -0,0 +1,114 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Dataflow + + +
Previous + Up + Next +
+

Module Dataflow

+
+
module Dataflow: sig .. end
A framework for data flow analysis for CIL code. Before using + this framework, you must initialize the Control-flow Graph for your + program, e.g using Cfg.computeFileCFG
+
+
type 'a action = + + + + + + + + + + + + + + +
+| +Default(*The default action*)
+| +Done of 'a(*Do not do the default action. Use this result*)
+| +Post of ('a -> 'a)(*The default action, followed by the given + transformer*)
+ + +
type 'a stmtaction = + + + + + + + + + + + + + + +
+| +SDefault(*The default action*)
+| +SDone(*Do not visit this statement or its successors*)
+| +SUse of 'a(*Visit the instructions and successors of this statement + as usual, but use the specified state instead of the + one that was passed to doStmt*)
+ + +
type 'a guardaction = + + + + + + + + + + + + + + +
+| +GDefault(*The default state*)
+| +GUse of 'a(*Use this data for the branch*)
+| +GUnreachable(*The branch will never be taken.*)
+ + +
module type ForwardsTransfer = sig .. end
module ForwardsDataFlow: 
functor (T : ForwardsTransfer) -> sig .. end
module type BackwardsTransfer = sig .. end
module BackwardsDataFlow: 
functor (T : BackwardsTransfer) -> sig .. end
\ No newline at end of file diff --git a/cil/doc/api/Dominators.html b/cil/doc/api/Dominators.html new file mode 100644 index 0000000..4d8eaf9 --- /dev/null +++ b/cil/doc/api/Dominators.html @@ -0,0 +1,58 @@ + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Dominators + + +
Previous + Up + 
+

Module Dominators

+
+
module Dominators: sig .. end
Compute dominators using data flow analysis
+
+
+Author: George Necula + 5/28/2004 +
+
val computeIDom : Cil.fundec -> Cil.stmt option Inthash.t
+Invoke on a code after filling in the CFG info and it computes the + immediate dominator information. We map each statement to its immediate + dominator (None for the start statement, and for the unreachable + statements).
+
+
val getIdom : Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt option
+This is like Inthash.find but gives an error if the information is + Not_found
+
+
val dominates : Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt -> bool
+Check whether one statement dominates another.
+
+
val findNaturalLoops : Cil.fundec -> Cil.stmt option Inthash.t -> (Cil.stmt * Cil.stmt list) list
+Compute the start of the natural loops. This assumes that the "idom" + field has been computed. For each start, keep a list of origin of a back + edge. The loop consists of the loop start and all predecessors of the + origins of back edges, up to and including the loop start
+
+ \ No newline at end of file diff --git a/cil/doc/api/Errormsg.html b/cil/doc/api/Errormsg.html new file mode 100644 index 0000000..bc19472 --- /dev/null +++ b/cil/doc/api/Errormsg.html @@ -0,0 +1,141 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Errormsg + + +
Previous + Up + Next +
+

Module Errormsg

+
+
module Errormsg: sig .. end
Utility functions for error-reporting
+
+
val logChannel : Pervasives.out_channel Pervasives.ref
+A channel for printing log messages
+
+
val debugFlag : bool Pervasives.ref
+If set then print debugging info
+
+
val verboseFlag : bool Pervasives.ref
val warnFlag : bool Pervasives.ref
+Set to true if you want to see all warnings.
+
+
exception Error
+
+Error reporting functions raise this exception
+
+
val error : ('a, unit, Pretty.doc, unit) format4 -> 'a
+Prints an error message of the form Error: .... + Use in conjunction with s, for example: E.s (E.error ... ).
+
+
val bug : ('a, unit, Pretty.doc, unit) format4 -> 'a
+Similar to error except that its output has the form Bug: ...
+
+
val unimp : ('a, unit, Pretty.doc, unit) format4 -> 'a
+Similar to error except that its output has the form Unimplemented: ...
+
+
val s : 'a -> 'b
+Stop the execution by raising an Error.
+
+
val hadErrors : bool Pervasives.ref
+This is set whenever one of the above error functions are called. It must + be cleared manually
+
+
val warn : ('a, unit, Pretty.doc, unit) format4 -> 'a
+Like Errormsg.error but does not raise the Errormsg.Error + exception. Return type is unit.
+
+
val warnOpt : ('a, unit, Pretty.doc, unit) format4 -> 'a
+Like Errormsg.warn but optional. Printed only if the + Errormsg.warnFlag is set
+
+
val log : ('a, unit, Pretty.doc, unit) format4 -> 'a
+Print something to logChannel
+
+
val logg : ('a, unit, Pretty.doc, unit) format4 -> 'a
+same as Errormsg.log but do not wrap lines
+
+
val null : ('a, unit, Pretty.doc, unit) format4 -> 'a
+Do not actually print (i.e. print to /dev/null)
+
+
val pushContext : (unit -> Pretty.doc) -> unit
+Registers a context printing function
+
+
val popContext : unit -> unit
+Removes the last registered context printing function
+
+
val showContext : unit -> unit
+Show the context stack to stderr
+
+
val withContext : (unit -> Pretty.doc) -> ('a -> 'b) -> 'a -> 'b
+To ensure that the context is registered and removed properly, use the + function below
+
+
val newline : unit -> unit
val newHline : unit -> unit
val getPosition : unit -> int * string * int
val getHPosition : unit -> int * string
+high-level position
+
+
val setHLine : int -> unit
val setHFile : string -> unit
val setCurrentLine : int -> unit
val setCurrentFile : string -> unit

type location = { + + + + + + + + + + + + + + + + + + + +
+   +file : string;(*The file name*)
+   +line : int;(*The line number*)
+   +hfile : string;(*The high-level file name, or "" if not present*)
+   +hline : int;(*The high-level line number, or 0 if not present*)
+} + +
+Type for source-file locations
+
+ +
val d_loc : unit -> location -> Pretty.doc
val d_hloc : unit -> location -> Pretty.doc
val getLocation : unit -> location
val parse_error : string -> 'a
val locUnknown : location
+An unknown location for use when you need one but you don't have one
+
+
val readingFromStdin : bool Pervasives.ref
+Records whether the stdin is open for reading the goal *
+
+
val startParsing : ?useBasename:bool -> string -> Lexing.lexbuf
val startParsingFromString : ?file:string -> ?line:int -> string -> Lexing.lexbuf
val finishParsing : unit -> unit
\ No newline at end of file diff --git a/cil/doc/api/Formatcil.html b/cil/doc/api/Formatcil.html new file mode 100644 index 0000000..8dee76d --- /dev/null +++ b/cil/doc/api/Formatcil.html @@ -0,0 +1,84 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Formatcil + + +
Previous + Up + Next +
+

Module Formatcil

+
+
module Formatcil: sig .. end
An Interpreter for constructing CIL constructs
+
+
val cExp : string -> (string * Cil.formatArg) list -> Cil.exp
+Constructs an expression based on the program and the list of arguments. + Each argument consists of a name followed by the actual data. This + argument will be placed instead of occurrences of "%v:name" in the pattern + (where the "v" is dependent on the type of the data). The parsing of the + string is memoized. * Only the first expression is parsed.
+
+
val cLval : string -> (string * Cil.formatArg) list -> Cil.lval
+Constructs an lval based on the program and the list of arguments. + Only the first lvalue is parsed. + The parsing of the string is memoized.
+
+
val cType : string -> (string * Cil.formatArg) list -> Cil.typ
+Constructs a type based on the program and the list of arguments. + Only the first type is parsed. + The parsing of the string is memoized.
+
+
val cInstr : string -> Cil.location -> (string * Cil.formatArg) list -> Cil.instr
+Constructs an instruction based on the program and the list of arguments. + Only the first instruction is parsed. + The parsing of the string is memoized.
+
+
val cStmt : string ->
       (string -> Cil.typ -> Cil.varinfo) ->
       Cil.location -> (string * Cil.formatArg) list -> Cil.stmt
val cStmts : string ->
       (string -> Cil.typ -> Cil.varinfo) ->
       Cil.location -> (string * Cil.formatArg) list -> Cil.stmt list
+Constructs a list of statements
+
+
val dExp : string -> Cil.exp -> Cil.formatArg list option
+Deconstructs an expression based on the program. Produces an optional + list of format arguments. The parsing of the string is memoized.
+
+
val dLval : string -> Cil.lval -> Cil.formatArg list option
+Deconstructs an lval based on the program. Produces an optional + list of format arguments. The parsing of the string is memoized.
+
+
val dType : string -> Cil.typ -> Cil.formatArg list option
+Deconstructs a type based on the program. Produces an optional list of + format arguments. The parsing of the string is memoized.
+
+
val dInstr : string -> Cil.instr -> Cil.formatArg list option
+Deconstructs an instruction based on the program. Produces an optional + list of format arguments. The parsing of the string is memoized.
+
+
val noMemoize : bool Pervasives.ref
+If set then will not memoize the parsed patterns
+
+
val test : unit -> unit
+Just a testing function
+
+ \ No newline at end of file diff --git a/cil/doc/api/Pretty.MakeMapPrinter.html b/cil/doc/api/Pretty.MakeMapPrinter.html new file mode 100644 index 0000000..9693a68 --- /dev/null +++ b/cil/doc/api/Pretty.MakeMapPrinter.html @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Pretty.MakeMapPrinter + + +
 Up + Next +
+

Functor Pretty.MakeMapPrinter

+
+
module MakeMapPrinter: 
functor (Map : sig
type key 

+
+
type 'a t 

+
+
val fold : (key -> 'a -> 'b -> 'b) ->
       'a t -> 'b -> 'b
end) -> sig .. end
Format maps.
+ + + + + +
Parameters: + + + + +
+Map:sig + type key + type 'a t + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + end +
+
+
+
val docMap : ?sep:Pretty.doc ->
       (Map.key -> 'a -> Pretty.doc) -> unit -> 'a Map.t -> Pretty.doc
+Format a map, analogous to docList.
+
+
val d_map : ?dmaplet:(Pretty.doc -> Pretty.doc -> Pretty.doc) ->
       string ->
       (unit -> Map.key -> Pretty.doc) ->
       (unit -> 'a -> Pretty.doc) -> unit -> 'a Map.t -> Pretty.doc
+Format a map, analogous to d_list.
+
+ \ No newline at end of file diff --git a/cil/doc/api/Pretty.MakeSetPrinter.html b/cil/doc/api/Pretty.MakeSetPrinter.html new file mode 100644 index 0000000..e9343b2 --- /dev/null +++ b/cil/doc/api/Pretty.MakeSetPrinter.html @@ -0,0 +1,63 @@ + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Pretty.MakeSetPrinter + + +
Previous + Up + 
+

Functor Pretty.MakeSetPrinter

+
+
module MakeSetPrinter: 
functor (Set : sig
type elt 

+
+
type t 

+
+
val fold : (elt -> 'a -> 'a) ->
       t -> 'a -> 'a
end) -> sig .. end
Format sets.
+ + + + + +
Parameters: + + + + +
+Set:sig + type elt + type t + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + end +
+
+
+
val docSet : ?sep:Pretty.doc -> (Set.elt -> Pretty.doc) -> unit -> Set.t -> Pretty.doc
+Format a set, analogous to docList.
+
+
val d_set : string -> (unit -> Set.elt -> Pretty.doc) -> unit -> Set.t -> Pretty.doc
+Format a set, analogous to d_list.
+
+ \ No newline at end of file diff --git a/cil/doc/api/Pretty.html b/cil/doc/api/Pretty.html new file mode 100644 index 0000000..c9c48c8 --- /dev/null +++ b/cil/doc/api/Pretty.html @@ -0,0 +1,268 @@ + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Pretty + + +
 Up + Next +
+

Module Pretty

+
+
module Pretty: sig .. end
Utility functions for pretty-printing. The major features provided by + this module are
    +
  • An fprintf-style interface with support for user-defined printers
    • +
  • The printout is fit to a width by selecting some of the optional newlines
    • +
  • Constructs for alignment and indentation
    • +
  • Print ellipsis starting at a certain nesting depth
    • +
  • Constructs for printing lists and arrays
    • +
+ + Pretty-printing occurs in two stages:
    +
  • Construct a Pretty.doc object that encodes all of the elements to be + printed + along with alignment specifiers and optional and mandatory newlines
    • +
  • Format the Pretty.doc to a certain width and emit it as a string, to an + output stream or pass it to a user-defined function
    • +
+ + The formatting algorithm is not optimal but it does a pretty good job while + still operating in linear time. The original version was based on a pretty + printer by Philip Wadler which turned out to not scale to large jobs.
+
+
+API
+
type doc
+
+The type of unformated documents. Elements of this type can be + constructed in two ways. Either with a number of constructor shown below, + or using the Pretty.dprintf function with a printf-like interface. + The Pretty.dprintf method is slightly slower so we do not use it for + large jobs such as the output routines for a compiler. But we use it for + small jobs such as logging and error messages.
+
+ +
+Constructors for the doc type.
+
val nil : doc
+Constructs an empty document
+
+
val (++) : doc -> doc -> doc
+Concatenates two documents. This is an infix operator that associates to + the left.
+
+
val concat : doc -> doc -> doc
val text : string -> doc
+A document that prints the given string
+
+
val num : int -> doc
+A document that prints an integer in decimal form
+
+
val real : float -> doc
+A document that prints a real number
+
+
val chr : char -> doc
+A document that prints a character. This is just like Pretty.text + with a one-character string.
+
+
val line : doc
+A document that consists of a mandatory newline. This is just like (text + "\n"). The new line will be indented to the current indentation level, + unless you use Pretty.leftflush right after this.
+
+
val leftflush : doc
+Use after a Pretty.line to prevent the indentation. Whatever follows + next will be flushed left. Indentation resumes on the next line.
+
+
val break : doc
+A document that consists of either a space or a line break. Also called + an optional line break. Such a break will be + taken only if necessary to fit the document in a given width. If the break + is not taken a space is printed instead.
+
+
val align : doc
+Mark the current column as the current indentation level. Does not print + anything. All taken line breaks will align to this column. The previous + alignment level is saved on a stack.
+
+
val unalign : doc
+Reverts to the last saved indentation level.
+
+
val mark : doc
+Mark the beginning of a markup section. The width of a markup section is + considered 0 for the purpose of computing identation
+
+
val unmark : doc
+The end of a markup section
+
+
+Syntactic sugar
+
val indent : int -> doc -> doc
+Indents the document. Same as ((text " ") ++ align ++ doc ++ unalign), + with the specified number of spaces.
+
+
val markup : doc -> doc
+Prints a document as markup. The marked document cannot contain line + breaks or alignment constructs.
+
+
val seq : sep:doc -> doit:('a -> doc) -> elements:'a list -> doc
+Formats a sequence. sep is a separator, doit is a function that + converts an element to a document.
+
+
val docList : ?sep:doc -> ('a -> doc) -> unit -> 'a list -> doc
+An alternative function for printing a list. The unit argument is there + to make this function more easily usable with the Pretty.dprintf + interface. The first argument is a separator, by default a comma.
+
+
val d_list : string -> (unit -> 'a -> doc) -> unit -> 'a list -> doc
+sm: Yet another list printer. This one accepts the same kind of + printing function that Pretty.dprintf does, and itself works + in the dprintf context. Also accepts + a string as the separator since that's by far the most common.
+
+
val docArray : ?sep:doc ->
       (int -> 'a -> doc) -> unit -> 'a array -> doc
+Formats an array. A separator and a function that prints an array + element. The default separator is a comma.
+
+
val docOpt : ('a -> doc) -> unit -> 'a option -> doc
+Prints an 'a option with None or Some
+
+
val d_int32 : int32 -> doc
+Print an int32
+
+
val f_int32 : unit -> int32 -> doc
val d_int64 : int64 -> doc
val f_int64 : unit -> int64 -> doc
module MakeMapPrinter: 
functor (Map : sig
type key 

+
+
type 'a t 

+
+
val fold : (key -> 'a -> 'b -> 'b) ->
       'a t -> 'b -> 'b
end) -> sig .. end
+Format maps. +
+
module MakeSetPrinter: 
functor (Set : sig
type elt 

+
+
type t 

+
+
val fold : (elt -> 'a -> 'a) ->
       t -> 'a -> 'a
end) -> sig .. end
+Format sets. +
+
val insert : unit -> doc -> doc
+A function that is useful with the printf-like interface
+
+
val dprintf : ('a, unit, doc, doc) format4 -> 'a
+This function provides an alternative method for constructing + doc objects. The first argument for this function is a format string + argument (of type ('a, unit, doc) format; if you insist on + understanding what that means see the module Printf). The format string + is like that for the printf function in C, except that it understands a + few more formatting controls, all starting with the @ character. +

+ + See the gprintf function if you want to pipe the result of dprintf into + some other functions. +

+ + The following special formatting characters are understood (these do not + correspond to arguments of the function):

+ + In addition to the usual printf % formatting characters the following two + new characters are supported:
    +
  • %t Corresponds to an argument of type unit -> doc. This argument is + invoked to produce a document
    • +
  • %a Corresponds to two arguments. The first of type unit -> 'a -> doc + and the second of type 'a. (The extra unit is do to the + peculiarities of the built-in support for format strings in Ocaml. It + turns out that it is not a major problem.) Here is an example of how + you use this:
    • +
+ +
dprintf "Name=%s, SSN=%7d, Children=@[%a@]\n"
+             pers.name pers.ssn (docList (chr ',' ++ break) text)
+             pers.children
+

+ + The result of dprintf is a Pretty.doc. You can format the document and + emit it using the functions Pretty.fprint and Pretty.sprint.
+

+
val gprintf : (doc -> 'a) -> ('b, unit, doc, 'a) format4 -> 'b
+Like Pretty.dprintf but more general. It also takes a function that is + invoked on the constructed document but before any formatting is done. The + type of the format argument means that 'a is the type of the parameters of + this function, unit is the type of the first argument to %a and %t + formats, doc is the type of the intermediate result, and 'b is the type of + the result of gprintf.
+
+
val fprint : Pervasives.out_channel -> width:int -> doc -> unit
+Format the document to the given width and emit it to the given channel
+
+
val sprint : width:int -> doc -> string
+Format the document to the given width and emit it as a string
+
+
val fprintf : Pervasives.out_channel -> ('a, unit, doc) Pervasives.format -> 'a
+Like Pretty.dprintf followed by Pretty.fprint
+
+
val printf : ('a, unit, doc) Pervasives.format -> 'a
+Like Pretty.fprintf applied to stdout
+
+
val eprintf : ('a, unit, doc) Pervasives.format -> 'a
+Like Pretty.fprintf applied to stderr
+
+
val withPrintDepth : int -> (unit -> unit) -> unit
+Invokes a thunk, with printDepth temporarily set to the specified value
+
+
+The following variables can be used to control the operation of the printer
+
val printDepth : int Pervasives.ref
+Specifies the nesting depth of the align/unalign pairs at which + everything is replaced with ellipsis
+
+
val printIndent : bool Pervasives.ref
+If false then does not indent
+
+
val fastMode : bool Pervasives.ref
+If set to true then optional breaks are taken only when the document + has exceeded the given width. This means that the printout will looked + more ragged but it will be faster
+
+
val flushOften : bool Pervasives.ref
+If true the it flushes after every print
+
+
val countNewLines : int Pervasives.ref
+Keep a running count of the taken newlines. You can read and write this + from the client code if you want
+
+
val auto_printer : string -> 'a
+A function that when used at top-level in a module will direct + the pa_prtype module generate automatically the printing functions for a + type
+
+ \ No newline at end of file diff --git a/cil/doc/api/Stats.html b/cil/doc/api/Stats.html new file mode 100644 index 0000000..b3f8aa4 --- /dev/null +++ b/cil/doc/api/Stats.html @@ -0,0 +1,69 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Stats + + +
Previous + Up + Next +
+

Module Stats

+
+
module Stats: sig .. end
Utilities for maintaining timing statistics
+
+
val reset : bool -> unit
+Resets all the timings. Invoke with "true" if you want to switch to using + the hardware performance counters from now on. You get an exception if + there are not performance counters available
+
+
exception NoPerfCount
+
val has_performance_counters : unit -> bool
+Check if we have performance counters
+
+
val sample_pentium_perfcount_20 : unit -> int
+Sample the current cycle count, in megacycles.
+
+
val sample_pentium_perfcount_10 : unit -> int
+Sample the current cycle count, in kilocycles.
+
+
val time : string -> ('a -> 'b) -> 'a -> 'b
+Time a function and associate the time with the given string. If some + timing information is already associated with that string, then accumulate + the times. If this function is invoked within another timed function then + you can have a hierarchy of timings
+
+
val repeattime : float -> string -> ('a -> 'b) -> 'a -> 'b
+repeattime is like time but runs the function several times until the total + running time is greater or equal to the first argument. The total time is + then divided by the number of times the function was run.
+
+
val print : Pervasives.out_channel -> string -> unit
+Print the current stats preceeded by a message
+
+
val lastTime : float Pervasives.ref
+Time a function and set lastTime to the time it took
+
+
val timethis : ('a -> 'b) -> 'a -> 'b
\ No newline at end of file diff --git a/cil/doc/api/index.html b/cil/doc/api/index.html new file mode 100644 index 0000000..f9636b2 --- /dev/null +++ b/cil/doc/api/index.html @@ -0,0 +1,83 @@ + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) + + +

CIL API Documentation (version 1.3.5)

+Index of types
+Index of exceptions
+Index of values
+Index of class methods
+Index of classes
+Index of class types
+Index of modules
+Index of module types
+

+ + + + + + + + + + + + +
Pretty
+Utility functions for pretty-printing. +
+
Errormsg
+Utility functions for error-reporting +
+
Clist
+Utilities for managing "concatenable lists" (clists). +
+
Stats
+Utilities for maintaining timing statistics +
+
Cil
+CIL API Documentation. +
+
Formatcil
+An Interpreter for constructing CIL constructs +
+
Alpha
+ALPHA conversion +
+
Cillower
+A number of lowering passes over CIL +
+
Cfg
+Code to compute the control-flow graph of a function or file. +
+
Dataflow
+A framework for data flow analysis for CIL code. +
+
Dominators
+Compute dominators using data flow analysis +
+
+ + \ No newline at end of file diff --git a/cil/doc/api/index_attributes.html b/cil/doc/api/index_attributes.html new file mode 100644 index 0000000..347bfa9 --- /dev/null +++ b/cil/doc/api/index_attributes.html @@ -0,0 +1,30 @@ + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Index of class attributes + + +

Index of class attributes

+ +

+ + \ No newline at end of file diff --git a/cil/doc/api/index_class_types.html b/cil/doc/api/index_class_types.html new file mode 100644 index 0000000..4c7faef --- /dev/null +++ b/cil/doc/api/index_class_types.html @@ -0,0 +1,41 @@ + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Index of class types + + +

Index of class types

+ + + + + + +

C
cilPrinter [Cil]
+A printer interface for CIL trees. +
+
cilVisitor [Cil]
+A visitor interface for traversing CIL trees. +
+

+ + \ No newline at end of file diff --git a/cil/doc/api/index_classes.html b/cil/doc/api/index_classes.html new file mode 100644 index 0000000..1a5ba7d --- /dev/null +++ b/cil/doc/api/index_classes.html @@ -0,0 +1,46 @@ + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Index of classes + + +

Index of classes

+ + + + + + + + + + +

D
defaultCilPrinterClass [Cil]

N
nopCilVisitor [Cil]
+Default Visitor. +
+

P
plainCilPrinterClass [Cil]
+These are pretty-printers that will show you more details on the internal + CIL representation, without trying hard to make it look like C +
+

+ + \ No newline at end of file diff --git a/cil/doc/api/index_exceptions.html b/cil/doc/api/index_exceptions.html new file mode 100644 index 0000000..e774a65 --- /dev/null +++ b/cil/doc/api/index_exceptions.html @@ -0,0 +1,53 @@ + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Index of exceptions + + +

Index of exceptions

+ + + + + + + + + + + + + +

E
Error [Errormsg]
+Error reporting functions raise this exception +
+

L
LenOfArray [Cil]
+Raised when Cil.lenOfArray fails either because the length is None + or because it is a non-constant expression +
+

N
NoPerfCount [Stats]

S
SizeOfError [Cil]
+Raised when one of the bitsSizeOf functions cannot compute the size of a + type. +
+

+ + \ No newline at end of file diff --git a/cil/doc/api/index_methods.html b/cil/doc/api/index_methods.html new file mode 100644 index 0000000..1558de3 --- /dev/null +++ b/cil/doc/api/index_methods.html @@ -0,0 +1,228 @@ + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Index of class methods + + +

Index of class methods

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

D
dBlock [Cil.cilPrinter]
+Dump a control-flow block to a file with a given indentation. +
+
dGlobal [Cil.cilPrinter]
+Dump a global to a file with a given indentation. +
+
dInit [Cil.cilPrinter]
+Dump a global to a file with a given indentation. +
+
dStmt [Cil.cilPrinter]
+Dump a control-flow statement to a file with a given indentation. +
+

P
pAttr [Cil.cilPrinter]
+Attribute. +
+
pAttrParam [Cil.cilPrinter]
+Attribute parameter +
+
pAttrs [Cil.cilPrinter]
+Attribute lists +
+
pBlock [Cil.cilPrinter]
pExp [Cil.cilPrinter]
+Print expressions +
+
pFieldDecl [Cil.cilPrinter]
+A field declaration +
+
pGlobal [Cil.cilPrinter]
+Global (vars, types, etc.). +
+
pInit [Cil.cilPrinter]
+Print initializers. +
+
pInstr [Cil.cilPrinter]
+Invoked on each instruction occurrence. +
+
pLabel [Cil.cilPrinter]
+Print a label. +
+
pLineDirective [Cil.cilPrinter]
+Print a line-number. +
+
pLval [Cil.cilPrinter]
+Invoked on each lvalue occurrence +
+
pOffset [Cil.cilPrinter]
+Invoked on each offset occurrence. +
+
pStmt [Cil.cilPrinter]
+Control-flow statement. +
+
pStmtKind [Cil.cilPrinter]
+Print a statement kind. +
+
pType [Cil.cilPrinter]
pVDecl [Cil.cilPrinter]
+Invoked for each variable declaration. +
+
pVar [Cil.cilPrinter]
+Invoked on each variable use. +
+

Q
queueInstr [Cil.cilVisitor]
+Add here instructions while visiting to queue them to preceede the + current statement or instruction being processed. +
+

U
unqueueInstr [Cil.cilVisitor]
+Gets the queue of instructions and resets the queue. +
+

V
vattr [Cil.cilVisitor]
+Attribute. +
+
vattrparam [Cil.cilVisitor]
+Attribute parameters. +
+
vblock [Cil.cilVisitor]
+Block. +
+
vexpr [Cil.cilVisitor]
+Invoked on each expression occurrence. +
+
vfunc [Cil.cilVisitor]
+Function definition. +
+
vglob [Cil.cilVisitor]
+Global (vars, types, + etc.) +
+
vinit [Cil.cilVisitor]
+Initializers for globals +
+
vinitoffs [Cil.cilVisitor]
+Invoked on each offset appearing in the list of a + CompoundInit initializer. +
+
vinst [Cil.cilVisitor]
+Invoked on each instruction occurrence. +
+
vlval [Cil.cilVisitor]
+Invoked on each lvalue occurrence +
+
voffs [Cil.cilVisitor]
+Invoked on each offset occurrence that is *not* as part + of an initializer list specification, i.e. +
+
vstmt [Cil.cilVisitor]
+Control-flow statement. +
+
vtype [Cil.cilVisitor]
+Use of some type. +
+
vvdec [Cil.cilVisitor]
+Invoked for each variable declaration. +
+
vvrbl [Cil.cilVisitor]
+Invoked on each variable use. +
+

+ + \ No newline at end of file diff --git a/cil/doc/api/index_module_types.html b/cil/doc/api/index_module_types.html new file mode 100644 index 0000000..244d402 --- /dev/null +++ b/cil/doc/api/index_module_types.html @@ -0,0 +1,36 @@ + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Index of module types + + +

Index of module types

+ + + + + + + +

B
BackwardsTransfer [Dataflow]

F
ForwardsTransfer [Dataflow]

+ + \ No newline at end of file diff --git a/cil/doc/api/index_modules.html b/cil/doc/api/index_modules.html new file mode 100644 index 0000000..090693f --- /dev/null +++ b/cil/doc/api/index_modules.html @@ -0,0 +1,108 @@ + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Index of modules + + +

Index of modules

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

A
Alpha
+ALPHA conversion +
+

B
BackwardsDataFlow [Dataflow]

C
Cfg
+Code to compute the control-flow graph of a function or file. +
+
Cil
+CIL API Documentation. +
+
Cillower
+A number of lowering passes over CIL +
+
Clist
+Utilities for managing "concatenable lists" (clists). +
+

D
Dataflow
+A framework for data flow analysis for CIL code. +
+
Dominators
+Compute dominators using data flow analysis +
+

E
Errormsg
+Utility functions for error-reporting +
+

F
Formatcil
+An Interpreter for constructing CIL constructs +
+
ForwardsDataFlow [Dataflow]

M
MakeMapPrinter [Pretty]
+Format maps. +
+
MakeSetPrinter [Pretty]
+Format sets. +
+

P
Pretty
+Utility functions for pretty-printing. +
+

S
Stats
+Utilities for maintaining timing statistics +
+

+ + \ No newline at end of file diff --git a/cil/doc/api/index_types.html b/cil/doc/api/index_types.html new file mode 100644 index 0000000..1974acd --- /dev/null +++ b/cil/doc/api/index_types.html @@ -0,0 +1,271 @@ + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Index of types + + +

Index of types

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

A
action [Dataflow]
alphaTableData [Alpha]
+This is the type of the elements of the alpha renaming table. +
+
attribute [Cil]
attributeClass [Cil]
+Various classes of attributes +
+
attributes [Cil]
+Attributes are lists sorted by the attribute name. +
+
attrparam [Cil]
+The type of parameters of attributes +
+

B
binop [Cil]
+Binary operations +
+
block [Cil]
+A block is a sequence of statements with the control falling through from + one element to the next +
+

C
clist [Clist]
+The clist datatype. +
+
comment [Cil]
compinfo [Cil]
+The definition of a structure or union type. +
+
constant [Cil]
+Literal constants +
+

D
doc [Pretty]
+The type of unformated documents. +
+

E
enuminfo [Cil]
+Information about an enumeration +
+
existsAction [Cil]
+A datatype to be used in conjunction with existsType +
+
exp [Cil]
+Expressions (Side-effect free) +
+

F
featureDescr [Cil]
+To be able to add/remove features easily, each feature should be package + as an interface with the following interface. +
+
fieldinfo [Cil]
+Information about a struct/union field +
+
file [Cil]
+Top-level representation of a C source file +
+
fkind [Cil]
+Various kinds of floating-point numbers +
+
formatArg [Cil]
+The type of argument for the interpreter +
+
fundec [Cil]
+Function definitions. +
+

G
global [Cil]
+A global declaration or definition +
+
guardaction [Dataflow]

I
ikind [Cil]
+Various kinds of integers +
+
init [Cil]
+Initializers for global variables. +
+
initinfo [Cil]
+We want to be able to update an initializer in a global variable, so we + define it as a mutable field +
+
instr [Cil]
+Instructions. +
+

L
label [Cil]
+Labels +
+
lhost [Cil]
+The host part of an Cil.lval. +
+
lineDirectiveStyle [Cil]
+Styles of printing line directives +
+
location [Cil]
+Describes a location in a source file. +
+
location [Errormsg]
+Type for source-file locations +
+
lval [Cil]
+An lvalue +
+

O
offset [Cil]
+The offset part of an Cil.lval. +
+

S
stmt [Cil]
+Statements. +
+
stmtaction [Dataflow]
stmtkind [Cil]
+The various kinds of control-flow statements statements +
+
storage [Cil]
+Storage-class information +
+

T
t [Dataflow.BackwardsTransfer]
+The type of the data we compute for each block start. +
+
t [Dataflow.ForwardsTransfer]
+The type of the data we compute for each block start. +
+
typ [Cil]
typeinfo [Cil]
+Information about a defined type +
+
typsig [Cil]
+Type signatures. +
+

U
undoAlphaElement [Alpha]
+This is the type of the elements that are recorded by the alpha + conversion functions in order to be able to undo changes to the tables + they modify. +
+
unop [Cil]
+Unary operators +
+

V
varinfo [Cil]
+Information about a variable. +
+
visitAction [Cil]
+Different visiting actions. +
+

+ + \ No newline at end of file diff --git a/cil/doc/api/index_values.html b/cil/doc/api/index_values.html new file mode 100644 index 0000000..799daaf --- /dev/null +++ b/cil/doc/api/index_values.html @@ -0,0 +1,1964 @@ + + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Index of values + + +

Index of values

+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +

(++) [Pretty]
+Concatenates two documents. +
+

A
addAttribute [Cil]
+Add an attribute. +
+
addAttributes [Cil]
+Add a list of attributes. +
+
addOffset [Cil]
+addOffset o1 o2 adds o1 to the end of o2. +
+
addOffsetLval [Cil]
+Add an offset at the end of an lvalue. +
+
additiveLevel [Cil]
addrOfLevel [Cil]
align [Pretty]
+Mark the current column as the current indentation level. +
+
alignOf_int [Cil]
+The minimum alignment (in bytes) for a type. +
+
append [Clist]
+Append two clists +
+
argsToList [Cil]
+Obtain the argument list ([] if None) +
+
arrowLevel [Cil]
attributeHash [Cil]
+This table contains the mapping of predefined attributes to classes. +
+
auto_printer [Pretty]
+A function that when used at top-level in a module will direct + the pa_prtype module generate automatically the printing functions for a + type +
+

B
bitsOffset [Cil]
+Give a type of a base and an offset, returns the number of bits from the + base address and the width (also expressed in bits) for the subobject + denoted by the offset. +
+
bitsSizeOf [Cil]
+The size of a type, in bits. +
+
bitwiseLevel [Cil]
break [Pretty]
+A document that consists of either a space or a line break. +
+
bug [Cil]
+Like Errormsg.bug except that Cil.currentLoc is also printed +
+
bug [Errormsg]
+Similar to error except that its output has the form Bug: ... +
+

C
cExp [Formatcil]
+Constructs an expression based on the program and the list of arguments. +
+
cInstr [Formatcil]
+Constructs an instruction based on the program and the list of arguments. +
+
cLval [Formatcil]
+Constructs an lval based on the program and the list of arguments. +
+
cStmt [Formatcil]
cStmts [Formatcil]
+Constructs a list of statements +
+
cType [Formatcil]
+Constructs a type based on the program and the list of arguments. +
+
cfgFun [Cfg]
+Compute a control flow graph for fd. +
+
charConstPtrType [Cil]
+char const * +
+
charConstToInt [Cil]
+Given the character c in a (CChr c), sign-extend it to 32 bits. +
+
charPtrType [Cil]
+char * +
+
charType [Cil]
+char +
+
char_is_unsigned [Cil]
+Whether "char" is unsigned. +
+
checkBeforeAppend [Clist]
+A useful check to assert before an append. +
+
chr [Pretty]
+A document that prints a character. +
+
cilVersion [Cil]
+This are the CIL version numbers. +
+
cilVersionMajor [Cil]
cilVersionMinor [Cil]
cilVersionRevision [Cil]
clearCFGinfo [Cfg]
+clear the sid, succs, and preds fields of each statment in a function +
+
clearFileCFG [Cfg]
+clear the sid, succs, and preds fields of each statement. +
+
combinePredecessors [Dataflow.ForwardsTransfer]
+Take some old data for the start of a statement, and some new data for + the same point. +
+
combineStmtStartData [Dataflow.BackwardsTransfer]
+When the analysis reaches the start of a block, combine the old data + with the one we have just computed. +
+
combineSuccessors [Dataflow.BackwardsTransfer]
+Take the data from two successors and combine it +
+
compFullName [Cil]
+Get the full name of a comp +
+
compactStmts [Cil]
+Try to compress statements so as to get maximal basic blocks +
+
comparativeLevel [Cil]
compareLoc [Cil]
+Comparison function for locations. +
+
compute [Dataflow.BackwardsDataFlow]
+Fill in the T.stmtStartData, given a number of initial statements to + start from (the sinks for the backwards data flow). +
+
compute [Dataflow.ForwardsDataFlow]
+Fill in the T.stmtStartData, given a number of initial statements to + start from. +
+
computeCFGInfo [Cil]
+Compute the CFG information for all statements in a fundec and return a + list of the statements. +
+
computeFileCFG [Cfg]
+Compute the CFG for an entire file, by calling cfgFun on each function. +
+
computeFirstPredecessor [Dataflow.ForwardsTransfer]
+Give the first value for a predecessors, compute the value to be set + for the block +
+
computeIDom [Dominators]
+Invoke on a code after filling in the CFG info and it computes the + immediate dominator information. +
+
concat [Pretty]
constFold [Cil]
+Do constant folding on an expression. +
+
constFoldBinOp [Cil]
+Do constant folding on a binary operation. +
+
constFoldVisitor [Cil]
+A visitor that does constant folding. +
+
copy [Dataflow.ForwardsTransfer]
+Make a deep copy of the data +
+
copyCompInfo [Cil]
+Makes a shallow copy of a Cil.compinfo changing the name and the key. +
+
copyFunction [Cil]
+Create a deep copy of a function. +
+
copyVarinfo [Cil]
+Make a shallow copy of a varinfo and assign a new identifier +
+
countNewLines [Pretty]
+Keep a running count of the taken newlines. +
+
currentGlobal [Cil]
+A reference to the current global being visited +
+
currentLoc [Cil]
+A reference to the current location. +
+

D
dExp [Formatcil]
+Deconstructs an expression based on the program. +
+
dExp [Cil]
+Generate an Cil.exp to be used in case of errors. +
+
dGlobal [Cil]
+Generate a Cil.global to be used in case of errors. +
+
dInstr [Formatcil]
+Deconstructs an instruction based on the program. +
+
dInstr [Cil]
+Generate an Cil.instr to be used in case of errors. +
+
dLval [Formatcil]
+Deconstructs an lval based on the program. +
+
dType [Formatcil]
+Deconstructs a type based on the program. +
+
d_attr [Cil]
+Pretty-print an attribute using Cil.defaultCilPrinter +
+
d_attrlist [Cil]
+Pretty-print a list of attributes using Cil.defaultCilPrinter +
+
d_attrparam [Cil]
+Pretty-print an argument of an attribute using Cil.defaultCilPrinter +
+
d_binop [Cil]
+Pretty-print a binary operator +
+
d_block [Cil]
+Pretty-print a block using Cil.defaultCilPrinter. +
+
d_const [Cil]
+Pretty-print a constant +
+
d_exp [Cil]
+Pretty-print an expression using Cil.defaultCilPrinter +
+
d_fkind [Cil]
+Pretty-print a floating-point kind +
+
d_formatarg [Cil]
+Pretty-prints a format arg +
+
d_global [Cil]
+Pretty-print the internal representation of a global using + Cil.defaultCilPrinter. +
+
d_hloc [Errormsg]
d_ikind [Cil]
+Pretty-print an integer of a given kind +
+
d_init [Cil]
+Pretty-print an initializer using Cil.defaultCilPrinter. +
+
d_instr [Cil]
+Pretty-print an instruction using Cil.defaultCilPrinter +
+
d_int32 [Pretty]
+Print an int32 +
+
d_int64 [Pretty]
d_label [Cil]
+Pretty-print a label using Cil.defaultCilPrinter +
+
d_list [Pretty]
+sm: Yet another list printer. +
+
d_loc [Cil]
+Pretty-print a location +
+
d_loc [Errormsg]
d_lval [Cil]
+Pretty-print an lvalue using Cil.defaultCilPrinter +
+
d_map [Pretty.MakeMapPrinter]
+Format a map, analogous to d_list. +
+
d_offset [Cil]
+Pretty-print an offset using Cil.defaultCilPrinter, given the pretty + printing for the base. +
+
d_plainexp [Cil]
+Pretty-print the internal representation of an expression +
+
d_plaininit [Cil]
+Pretty-print the internal representation of an integer +
+
d_plainlval [Cil]
+Pretty-print the internal representation of an lvalue +
+
d_plaintype [Cil]
+Pretty-print the internal representation of a type +
+
d_set [Pretty.MakeSetPrinter]
+Format a set, analogous to d_list. +
+
d_shortglobal [Cil]
+Pretty-print a short description of the global. +
+
d_stmt [Cil]
+Pretty-print a statement using Cil.defaultCilPrinter. +
+
d_storage [Cil]
+Pretty-print storage-class information +
+
d_thisloc [Cil]
+Pretty-print the Cil.currentLoc +
+
d_type [Cil]
+Pretty-print a type using Cil.defaultCilPrinter +
+
d_typsig [Cil]
+Print a type signature +
+
d_unop [Cil]
+Pretty-print a unary operator +
+
debug [Dataflow.BackwardsTransfer]
+Whether to turn on debugging +
+
debug [Dataflow.ForwardsTransfer]
+Whether to turn on debugging +
+
debugFlag [Errormsg]
+If set then print debugging info +
+
defaultCilPrinter [Cil]
derefStarLevel [Cil]
dn_attr [Cil]
dn_attrlist [Cil]
dn_attrparam [Cil]
dn_exp [Cil]
+Versions of the above pretty printers, that don't print #line directives +
+
dn_global [Cil]
dn_init [Cil]
dn_instr [Cil]
dn_lval [Cil]
dn_stmt [Cil]
dn_type [Cil]
doGuard [Dataflow.ForwardsTransfer]
+Generate the successor to an If statement assuming the given expression + is nonzero. +
+
doInstr [Dataflow.BackwardsTransfer]
+The (backwards) transfer function for an instruction. +
+
doInstr [Dataflow.ForwardsTransfer]
+The (forwards) transfer function for an instruction. +
+
doStmt [Dataflow.BackwardsTransfer]
+The (backwards) transfer function for a branch. +
+
doStmt [Dataflow.ForwardsTransfer]
+The (forwards) transfer function for a statement. +
+
docAlphaTable [Alpha]
+Split the name in preparation for newAlphaName. +
+
docArray [Pretty]
+Formats an array. +
+
docCList [Clist]
+A document for printing a clist (similar to docList) +
+
docList [Pretty]
+An alternative function for printing a list. +
+
docMap [Pretty.MakeMapPrinter]
+Format a map, analogous to docList. +
+
docOpt [Pretty]
+Prints an 'a option with None or Some +
+
docSet [Pretty.MakeSetPrinter]
+Format a set, analogous to docList. +
+
dominates [Dominators]
+Check whether one statement dominates another. +
+
doubleType [Cil]
+double +
+
dprintf [Pretty]
+This function provides an alternative method for constructing + doc objects. +
+
dropAttribute [Cil]
+Remove all attributes with the given name. +
+
dropAttributes [Cil]
+Remove all attributes with names appearing in the string list. +
+
dummyFile [Cil]
+A dummy file +
+
dummyFunDec [Cil]
+A dummy function declaration handy when you need one as a placeholder. +
+
dummyInstr [Cil]
+A instr to serve as a placeholder +
+
dummyStmt [Cil]
+A statement consisting of just dummyInstr +
+
dumpBlock [Cil]
+Dump a block to a file using a given indentation. +
+
dumpFile [Cil]
+Pretty-print an entire file. +
+
dumpGlobal [Cil]
+Pretty-print a global. +
+
dumpInit [Cil]
+Dump an initializer to a file using a given indentation. +
+
dumpStmt [Cil]
+Dump a statement to a file using a given indentation. +
+

E
empty [Clist]
+The empty clist +
+
emptyFunction [Cil]
+Make an empty function +
+
eprintf [Pretty]
+Like Pretty.fprintf applied to stderr +
+
error [Cil]
+Like Errormsg.error except that Cil.currentLoc is also printed +
+
error [Errormsg]
+Prints an error message of the form Error: .... +
+
errorLoc [Cil]
+Like Cil.error except that it explicitly takes a location argument, + instead of using the Cil.currentLoc +
+
existsType [Cil]
+Scans a type by applying the function on all elements. +
+

F
f_int32 [Pretty]
f_int64 [Pretty]
fastMode [Pretty]
+If set to true then optional breaks are taken only when the document + has exceeded the given width. +
+
filterAttributes [Cil]
+Retains attributes with the given name +
+
filterStmt [Dataflow.BackwardsTransfer]
+Whether to put this predecessor block in the worklist. +
+
filterStmt [Dataflow.ForwardsTransfer]
+Whether to put this statement in the worklist. +
+
findNaturalLoops [Dominators]
+Compute the start of the natural loops. +
+
finishParsing [Errormsg]
flushOften [Pretty]
+If true the it flushes after every print +
+
foldGlobals [Cil]
+Fold over all globals, including the global initializer +
+
foldLeftCompound [Cil]
+Fold over the list of initializers in a Compound. +
+
foldLeftCompoundAll [Cil]
+Fold over the list of initializers in a Compound, like + Cil.foldLeftCompound but in the case of an array it scans even missing + zero initializers at the end of the array +
+
fold_left [Clist]
+A version of fold_left that works on clists +
+
forgcc [Cil]
+Return the string 's' if we're printing output for gcc, suppres + it if we're printing for CIL to parse back in. +
+
fprint [Pretty]
+Format the document to the given width and emit it to the given channel +
+
fprintf [Pretty]
+Like Pretty.dprintf followed by Pretty.fprint +
+
fromList [Clist]
+Convert an ordinary list to a clist +
+

G
gccBuiltins [Cil]
+A list of the GCC built-in functions. +
+
getAlphaPrefix [Alpha]
getCompField [Cil]
+Return a named fieldinfo in compinfo, or raise Not_found +
+
getGlobInit [Cil]
+Get the global initializer and create one if it does not already exist. +
+
getHPosition [Errormsg]
+high-level position +
+
getIdom [Dominators]
+This is like Inthash.find but gives an error if the information is + Not_found +
+
getLocation [Errormsg]
getParenthLevel [Cil]
+Parentheses level. +
+
getPosition [Errormsg]
get_globalLoc [Cil]
+Return the location of a global, or locUnknown +
+
get_instrLoc [Cil]
+Return the location of an instruction +
+
get_stmtLoc [Cil]
+Return the location of a statement, or locUnknown +
+
gprintf [Pretty]
+Like Pretty.dprintf but more general. +
+

H
hadErrors [Errormsg]
+This is set whenever one of the above error functions are called. +
+
hasAttribute [Cil]
+True if the named attribute appears in the attribute list. +
+
has_performance_counters [Stats]
+Check if we have performance counters +
+

I
increm [Cil]
+Increment an expression. +
+
indent [Pretty]
+Indents the document. +
+
indexLevel [Cil]
initCIL [Cil]
+Call this function to perform some initialization. +
+
insert [Pretty]
+A function that is useful with the printf-like interface +
+
insertImplicitCasts [Cil]
+Do insert implicit casts (default true) +
+
intPtrType [Cil]
+int * +
+
intType [Cil]
+int +
+
integer [Cil]
+Construct an integer of kind IInt. +
+
invalidStmt [Cil]
+An empty statement. +
+
isArithmeticType [Cil]
+True if the argument is an arithmetic type (i.e. +
+
isArrayType [Cil]
+True if the argument is an array type +
+
isCompleteType [Cil]
+Returns true if this is a complete type. +
+
isConstant [Cil]
+True if the expression is a compile-time constant +
+
isFunctionType [Cil]
+True if the argument is a function type +
+
isInteger [Cil]
+True if the given expression is a (possibly cast'ed) + character or an integer constant +
+
isIntegralType [Cil]
+True if the argument is an integral type (i.e. +
+
isPointerType [Cil]
+True if the argument is a pointer type +
+
isSigned [Cil]
+Returns true if and only if the given integer type is signed. +
+
isVoidPtrType [Cil]
isVoidType [Cil]
isZero [Cil]
+True if the given expression is a (possibly cast'ed) integer or character + constant with value zero +
+
iter [Clist]
+A version of iter that works on clists +
+
iterGlobals [Cil]
+Iterate over all globals, including the global initializer +
+

K
kinteger [Cil]
+Construct an integer of a given kind. +
+
kinteger64 [Cil]
+Construct an integer of a given kind, using OCaml's int64 type. +
+

L
lastTime [Stats]
+Time a function and set lastTime to the time it took +
+
leftflush [Pretty]
+Use after a Pretty.line to prevent the indentation. +
+
lenOfArray [Cil]
+Call to compute the array length as present in the array type, to an + integer. +
+
length [Clist]
+Find the length of a clist +
+
line [Pretty]
+A document that consists of a mandatory newline. +
+
lineDirectiveStyle [Cil]
+How to print line directives +
+
lineLength [Cil]
+The length used when wrapping output lines. +
+
little_endian [Cil]
+Whether the machine is little endian. +
+
loadBinaryFile [Cil]
+Read a Cil.file in binary form from the filesystem. +
+
locUnknown [Cil]
+Represents a location that cannot be determined +
+
locUnknown [Errormsg]
+An unknown location for use when you need one but you don't have one +
+
log [Errormsg]
+Print something to logChannel +
+
logChannel [Errormsg]
+A channel for printing log messages +
+
logg [Errormsg]
+same as Errormsg.log but do not wrap lines +
+
longType [Cil]
+long +
+
lowerConstants [Cil]
+Do lower constants (default true) +
+
lowerEnumVisitor [Cillower]
+Replace enumeration constants with integer constants +
+

M
makeFormalVar [Cil]
+Make a formal variable for a function. +
+
makeGlobalVar [Cil]
+Make a global variable. +
+
makeLocalVar [Cil]
+Make a local variable and add it to a function's slocals (only if insert = + true, which is the default). +
+
makeTempVar [Cil]
+Make a temporary variable and add it to a function's slocals. +
+
makeVarinfo [Cil]
+Make a varinfo. +
+
makeZeroInit [Cil]
+Make a initializer for zero-ing a data type +
+
map [Clist]
+Map a function over a clist. +
+
mapGlobals [Cil]
+Map over all globals, including the global initializer and change things + in place +
+
mapNoCopy [Cil]
+Like map but try not to make a copy of the list +
+
mapNoCopyList [Cil]
+Like map but each call can return a list. +
+
mark [Pretty]
+Mark the beginning of a markup section. +
+
markup [Pretty]
+Prints a document as markup. +
+
missingFieldName [Cil]
+This is a constant used as the name of an unnamed bitfield. +
+
mkAddrOf [Cil]
+Make an AddrOf. +
+
mkAddrOrStartOf [Cil]
+Like mkAddrOf except if the type of lval is an array then it uses + StartOf. +
+
mkBlock [Cil]
+Construct a block with no attributes, given a list of statements +
+
mkCast [Cil]
+Like Cil.mkCastT but uses typeOf to get oldt +
+
mkCastT [Cil]
+Construct a cast when having the old type of the expression. +
+
mkCompInfo [Cil]
+Creates a a (potentially recursive) composite type. +
+
mkEmptyStmt [Cil]
+Returns an empty statement (of kind Instr) +
+
mkFor [Cil]
+Make a for loop for(start; guard; next) { ... +
+
mkForIncr [Cil]
+Make a for loop for(i=start; i<past; i += incr) { ... +
+
mkMem [Cil]
+Make a Mem, while optimizing AddrOf. +
+
mkStmt [Cil]
+Construct a statement, given its kind. +
+
mkStmtOneInstr [Cil]
+Construct a statement consisting of just one instruction +
+
mkString [Cil]
+Make an expression that is a string constant (of pointer type) +
+
mkWhile [Cil]
+Make a while loop. +
+
mone [Cil]
+-1 +
+
msvcBuiltins [Cil]
+A list of the MSVC built-in functions. +
+
msvcMode [Cil]
+Whether the pretty printer should print output for the MS VC compiler. +
+

N
name [Dataflow.BackwardsTransfer]
+For debugging purposes, the name of the analysis +
+
name [Dataflow.ForwardsTransfer]
+For debugging purposes, the name of the analysis +
+
newAlphaName [Alpha]
+Create a new name based on a given name. +
+
newHline [Errormsg]
newVID [Cil]
+Generate a new variable ID. +
+
new_sid [Cil]
newline [Errormsg]
nil [Pretty]
+Constructs an empty document +
+
noMemoize [Formatcil]
+If set then will not memoize the parsed patterns +
+
nodeList [Cfg]
+All of the nodes in a file. +
+
null [Errormsg]
+Do not actually print (i.e. +
+
num [Pretty]
+A document that prints an integer in decimal form +
+
numNodes [Cfg]
+number of nodes in the CFG +
+

O
one [Cil]
+1 +
+

P
parseInt [Cil]
+Convert a string representing a C integer literal to an expression. +
+
parse_error [Errormsg]
partitionAttributes [Cil]
+Partition the attributes into classes:name attributes, function type, + and type attributes +
+
peepHole1 [Cil]
+Similar to peepHole2 except that the optimization window consists of + one statement, not two +
+
peepHole2 [Cil]
+A peephole optimizer that processes two adjacent statements and possibly + replaces them both. +
+
plainCilPrinter [Cil]
popContext [Errormsg]
+Removes the last registered context printing function +
+
prepareCFG [Cil]
+Prepare a function for CFG information computation by + Cil.computeCFGInfo. +
+
pretty [Dataflow.BackwardsTransfer]
+Pretty-print the state +
+
pretty [Dataflow.ForwardsTransfer]
+Pretty-print the state +
+
print [Stats]
+Print the current stats preceeded by a message +
+
printAttr [Cil]
+Print an attribute given a pretty printer +
+
printAttrs [Cil]
+Print a set of attributes given a pretty printer +
+
printBlock [Cil]
+Print a block given a pretty printer. +
+
printCfgChannel [Cfg]
+print control flow graph (in dot form) for fundec to channel +
+
printCfgFilename [Cfg]
+Print control flow graph (in dot form) for fundec to file +
+
printCilAsIs [Cil]
+Whether to print the CIL as they are, without trying to be smart and + print nicer code. +
+
printDepth [Pretty]
+Specifies the nesting depth of the align/unalign pairs at which + everything is replaced with ellipsis +
+
printExp [Cil]
+Print an expression given a pretty printer +
+
printGlobal [Cil]
+Print a global given a pretty printer +
+
printIndent [Pretty]
+If false then does not indent +
+
printInit [Cil]
+Print an initializer given a pretty printer. +
+
printInstr [Cil]
+Print an instruction given a pretty printer +
+
printLval [Cil]
+Print an lvalue given a pretty printer +
+
printStmt [Cil]
+Print a statement given a pretty printer. +
+
printType [Cil]
+Print a type given a pretty printer +
+
print_CIL_Input [Cil]
+Whether we print something that will only be used as input to our own + parser. +
+
printerForMaincil [Cil]
printf [Pretty]
+Like Pretty.fprintf applied to stdout +
+
pushContext [Errormsg]
+Registers a context printing function +
+
pushGlobal [Cil]
+CIL keeps the types at the beginning of the file and the variables at the + end of the file. +
+

R
readingFromStdin [Errormsg]
+Records whether the stdin is open for reading the goal * +
+
real [Pretty]
+A document that prints a real number +
+
registerAlphaName [Alpha]
+Register a name with an alpha conversion table to ensure that when later + we call newAlphaName we do not end up generating this one +
+
removeOffset [Cil]
+Remove ONE offset from the end of an offset sequence. +
+
removeOffsetLval [Cil]
+Remove ONE offset from the end of an lvalue. +
+
repeattime [Stats]
+repeattime is like time but runs the function several times until the total + running time is greater or equal to the first argument. +
+
reset [Stats]
+Resets all the timings. +
+
rev [Clist]
+Reverse a clist. +
+

S
s [Errormsg]
+Stop the execution by raising an Error. +
+
sample_pentium_perfcount_10 [Stats]
+Sample the current cycle count, in kilocycles. +
+
sample_pentium_perfcount_20 [Stats]
+Sample the current cycle count, in megacycles. +
+
saveBinaryFile [Cil]
+Write a Cil.file in binary form to the filesystem. +
+
saveBinaryFileChannel [Cil]
+Write a Cil.file in binary form to the filesystem. +
+
separateStorageModifiers [Cil]
+Separate out the storage-modifier name attributes +
+
seq [Pretty]
+Formats a sequence. +
+
setCurrentFile [Errormsg]
setCurrentLine [Errormsg]
setFormals [Cil]
+Update the formals of a fundec and make sure that the function type + has the same information. +
+
setFunctionType [Cil]
+Set the types of arguments and results as given by the function type + passed as the second argument. +
+
setFunctionTypeMakeFormals [Cil]
+Set the type of the function and make formal arguments for them +
+
setHFile [Errormsg]
setHLine [Errormsg]
setMaxId [Cil]
+Update the smaxid after you have populated with locals and formals + (unless you constructed those using Cil.makeLocalVar or + Cil.makeTempVar. +
+
setTypeAttrs [Cil]
setTypeSigAttrs [Cil]
+Replace the attributes of a signature (only at top level) +
+
showContext [Errormsg]
+Show the context stack to stderr +
+
single [Clist]
+Create a clist containing one element +
+
sizeOf [Cil]
splitFunctionType [Cil]
+Given a function type split it into return type, + arguments, is_vararg and attributes. +
+
splitFunctionTypeVI [Cil]
sprint [Pretty]
+Format the document to the given width and emit it as a string +
+
startParsing [Errormsg]
startParsingFromString [Errormsg]
start_id [Cfg]
+Next statement id that will be assigned. +
+
startsWith [Cil]
+sm: return true if the first is a prefix of the second string +
+
stmtStartData [Dataflow.BackwardsTransfer]
+For each block id, the data at the start. +
+
stmtStartData [Dataflow.ForwardsTransfer]
+For each statement id, the data at the start. +
+
stripCasts [Cil]
+Removes casts from this expression, but ignores casts within + other expression constructs. +
+

T
test [Formatcil]
+Just a testing function +
+
text [Pretty]
+A document that prints the given string +
+
time [Stats]
+Time a function and associate the time with the given string. +
+
timethis [Stats]
toList [Clist]
+Convert a clist to an ordinary list +
+
typeAddAttributes [Cil]
+Add some attributes to a type +
+
typeAttrs [Cil]
+Returns all the attributes contained in a type. +
+
typeOf [Cil]
+Compute the type of an expression +
+
typeOfLval [Cil]
+Compute the type of an lvalue +
+
typeOfSizeOf [Cil]
typeOffset [Cil]
+Compute the type of an offset from a base type +
+
typeRemoveAttributes [Cil]
+Remove all attributes with the given names from a type. +
+
typeSig [Cil]
+Compute a type signature +
+
typeSigAttrs [Cil]
+Get the top-level attributes of a signature +
+
typeSigWithAttrs [Cil]
+Like Cil.typeSig but customize the incorporation of attributes. +
+

U
uintPtrType [Cil]
+unsigned int * +
+
uintType [Cil]
+unsigned int +
+
ulongType [Cil]
+unsigned long +
+
unalign [Pretty]
+Reverts to the last saved indentation level. +
+
underscore_name [Cil]
+Whether the compiler generates assembly labels by prepending "_" to the + identifier. +
+
undoAlphaChanges [Alpha]
+Undo the changes to a table +
+
unimp [Cil]
+Like Errormsg.unimp except that Cil.currentLocis also printed +
+
unimp [Errormsg]
+Similar to error except that its output has the form Unimplemented: ... +
+
uniqueVarNames [Cil]
+Assign unique names to local variables. +
+
unmark [Pretty]
+The end of a markup section +
+
unrollType [Cil]
+Unroll a type until it exposes a non + TNamed. +
+
unrollTypeDeep [Cil]
+Unroll all the TNamed in a type (even under type constructors such as + TPtr, TFun or TArray. +
+
upointType [Cil]
useLogicalOperators [Cil]
+Whether to use the logical operands LAnd and LOr. +
+

V
var [Cil]
+Makes an lvalue out of a given variable +
+
verboseFlag [Errormsg]
visitCilAttributes [Cil]
+Visit a list of attributes +
+
visitCilBlock [Cil]
+Visit a block +
+
visitCilExpr [Cil]
visitCilFile [Cil]
+Visit a file. +
+
visitCilFileSameGlobals [Cil]
+A visitor for the whole file that does not change the globals (but maybe + changes things inside the globals). +
+
visitCilFunction [Cil]
+Visit a function definition +
+
visitCilGlobal [Cil]
+Visit a global +
+
visitCilInit [Cil]
+Visit an initializer +
+
visitCilInitOffset [Cil]
+Visit an initializer offset +
+
visitCilInstr [Cil]
+Visit an instruction +
+
visitCilLval [Cil]
+Visit an lvalue +
+
visitCilOffset [Cil]
+Visit an lvalue or recursive offset +
+
visitCilStmt [Cil]
+Visit a statement +
+
visitCilType [Cil]
+Visit a type +
+
visitCilVarDecl [Cil]
+Visit a variable declaration +
+
voidPtrType [Cil]
+void * +
+
voidType [Cil]
+void +
+

W
warn [Cil]
+Like Errormsg.warn except that Cil.currentLoc is also printed +
+
warn [Errormsg]
+Like Errormsg.error but does not raise the Errormsg.Error + exception. +
+
warnContext [Cil]
+Like Errormsg.warn except that Cil.currentLoc and context + is also printed +
+
warnContextOpt [Cil]
+Like Errormsg.warn except that Cil.currentLoc and context is also + printed. +
+
warnFlag [Errormsg]
+Set to true if you want to see all warnings. +
+
warnLoc [Cil]
+Like Cil.warn except that it explicitly takes a location argument, + instead of using the Cil.currentLoc +
+
warnOpt [Cil]
+Like Errormsg.warnOpt except that Cil.currentLoc is also printed. +
+
warnOpt [Errormsg]
+Like Errormsg.warn but optional. +
+
wcharKind [Cil]
+wchar_t (depends on architecture) and is set when you call + Cil.initCIL. +
+
wcharType [Cil]
withContext [Errormsg]
+To ensure that the context is registered and removed properly, use the + function below +
+
withPrintDepth [Pretty]
+Invokes a thunk, with printDepth temporarily set to the specified value +
+

Z
zero [Cil]
+0 +
+

+ + \ No newline at end of file diff --git a/cil/doc/api/style.css b/cil/doc/api/style.css new file mode 100644 index 0000000..11ed40c --- /dev/null +++ b/cil/doc/api/style.css @@ -0,0 +1,32 @@ +a:visited {color : #416DFF; text-decoration : none; } +a:link {color : #416DFF; text-decoration : none;} +a:hover {color : Red; text-decoration : none; background-color: #5FFF88} +a:active {color : Red; text-decoration : underline; } +.keyword { font-weight : bold ; color : Red } +.keywordsign { color : #C04600 } +.superscript { font-size : 4 } +.subscript { font-size : 4 } +.comment { color : Green } +.constructor { color : Blue } +.type { color : #5C6585 } +.string { color : Maroon } +.warning { color : Red ; font-weight : bold } +.info { margin-left : 3em; margin-right : 3em } +.code { color : #465F91 ; } +h1 { font-size : 20pt ; text-align: center; } +h2 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90BDFF ;padding: 2px; } +h3 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90DDFF ;padding: 2px; } +h4 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90EDFF ;padding: 2px; } +h5 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #90FDFF ;padding: 2px; } +h6 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #C0FFFF ; padding: 2px; } +div.h7 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #E0FFFF ; padding: 2px; } +div.h8 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #F0FFFF ; padding: 2px; } +div.h9 { font-size : 20pt ; border: 1px solid #000000; margin-top: 5px; margin-bottom: 2px;text-align: center; background-color: #FFFFFF ; padding: 2px; } +.typetable { border-style : hidden } +.indextable { border-style : hidden } +.paramstable { border-style : hidden ; padding: 5pt 5pt} +body { background-color : White } +tr { background-color : White } +td.typefieldcomment { background-color : #FFFFFF } +pre { margin-bottom: 4px } +div.sig_block {margin-left: 2em} \ No newline at end of file diff --git a/cil/doc/api/type_Alpha.html b/cil/doc/api/type_Alpha.html new file mode 100644 index 0000000..b97c835 --- /dev/null +++ b/cil/doc/api/type_Alpha.html @@ -0,0 +1,43 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Alpha + + +sig
+  type 'a undoAlphaElement
+  type 'a alphaTableData
+  val newAlphaName :
+    alphaTable:(string, 'a Alpha.alphaTableData Pervasives.ref) Hashtbl.t ->
+    undolist:'a Alpha.undoAlphaElement list Pervasives.ref option ->
+    lookupname:string -> data:'a -> string * 'a
+  val registerAlphaName :
+    alphaTable:(string, 'a Alpha.alphaTableData Pervasives.ref) Hashtbl.t ->
+    undolist:'a Alpha.undoAlphaElement list Pervasives.ref option ->
+    lookupname:string -> data:'a -> unit
+  val docAlphaTable :
+    unit ->
+    (string, 'a Alpha.alphaTableData Pervasives.ref) Hashtbl.t -> Pretty.doc
+  val getAlphaPrefix : lookupname:string -> string
+  val undoAlphaChanges :
+    alphaTable:(string, 'a Alpha.alphaTableData Pervasives.ref) Hashtbl.t ->
+    undolist:'a Alpha.undoAlphaElement list -> unit
+end \ No newline at end of file diff --git a/cil/doc/api/type_Cfg.html b/cil/doc/api/type_Cfg.html new file mode 100644 index 0000000..996d773 --- /dev/null +++ b/cil/doc/api/type_Cfg.html @@ -0,0 +1,35 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cfg + + +sig
+  val computeFileCFG : Cil.file -> unit
+  val clearFileCFG : Cil.file -> unit
+  val cfgFun : Cil.fundec -> int
+  val clearCFGinfo : Cil.fundec -> unit
+  val printCfgChannel : Pervasives.out_channel -> Cil.fundec -> unit
+  val printCfgFilename : string -> Cil.fundec -> unit
+  val start_id : int Pervasives.ref
+  val nodeList : Cil.stmt list Pervasives.ref
+  val numNodes : int Pervasives.ref
+end \ No newline at end of file diff --git a/cil/doc/api/type_Cil.cilPrinter.html b/cil/doc/api/type_Cil.cilPrinter.html new file mode 100644 index 0000000..ff117f5 --- /dev/null +++ b/cil/doc/api/type_Cil.cilPrinter.html @@ -0,0 +1,48 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cil.cilPrinter + + +object
+  method dBlock : Pervasives.out_channel -> int -> Cil.block -> unit
+  method dGlobal : Pervasives.out_channel -> Cil.global -> unit
+  method dInit : Pervasives.out_channel -> int -> Cil.init -> unit
+  method dStmt : Pervasives.out_channel -> int -> Cil.stmt -> unit
+  method pAttr : Cil.attribute -> Pretty.doc * bool
+  method pAttrParam : unit -> Cil.attrparam -> Pretty.doc
+  method pAttrs : unit -> Cil.attributes -> Pretty.doc
+  method pBlock : unit -> Cil.block -> Pretty.doc
+  method pExp : unit -> Cil.exp -> Pretty.doc
+  method pFieldDecl : unit -> Cil.fieldinfo -> Pretty.doc
+  method pGlobal : unit -> Cil.global -> Pretty.doc
+  method pInit : unit -> Cil.init -> Pretty.doc
+  method pInstr : unit -> Cil.instr -> Pretty.doc
+  method pLabel : unit -> Cil.label -> Pretty.doc
+  method pLineDirective : ?forcefile:bool -> Cil.location -> Pretty.doc
+  method pLval : unit -> Cil.lval -> Pretty.doc
+  method pOffset : Pretty.doc -> Cil.offset -> Pretty.doc
+  method pStmt : unit -> Cil.stmt -> Pretty.doc
+  method pStmtKind : Cil.stmt -> unit -> Cil.stmtkind -> Pretty.doc
+  method pType : Pretty.doc option -> unit -> Cil.typ -> Pretty.doc
+  method pVDecl : unit -> Cil.varinfo -> Pretty.doc
+  method pVar : Cil.varinfo -> Pretty.doc
+end \ No newline at end of file diff --git a/cil/doc/api/type_Cil.cilVisitor.html b/cil/doc/api/type_Cil.cilVisitor.html new file mode 100644 index 0000000..efe3d13 --- /dev/null +++ b/cil/doc/api/type_Cil.cilVisitor.html @@ -0,0 +1,43 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cil.cilVisitor + + +object
+  method queueInstr : Cil.instr list -> unit
+  method unqueueInstr : unit -> Cil.instr list
+  method vattr : Cil.attribute -> Cil.attribute list Cil.visitAction
+  method vattrparam : Cil.attrparam -> Cil.attrparam Cil.visitAction
+  method vblock : Cil.block -> Cil.block Cil.visitAction
+  method vexpr : Cil.exp -> Cil.exp Cil.visitAction
+  method vfunc : Cil.fundec -> Cil.fundec Cil.visitAction
+  method vglob : Cil.global -> Cil.global list Cil.visitAction
+  method vinit : Cil.init -> Cil.init Cil.visitAction
+  method vinitoffs : Cil.offset -> Cil.offset Cil.visitAction
+  method vinst : Cil.instr -> Cil.instr list Cil.visitAction
+  method vlval : Cil.lval -> Cil.lval Cil.visitAction
+  method voffs : Cil.offset -> Cil.offset Cil.visitAction
+  method vstmt : Cil.stmt -> Cil.stmt Cil.visitAction
+  method vtype : Cil.typ -> Cil.typ Cil.visitAction
+  method vvdec : Cil.varinfo -> Cil.varinfo Cil.visitAction
+  method vvrbl : Cil.varinfo -> Cil.varinfo Cil.visitAction
+end \ No newline at end of file diff --git a/cil/doc/api/type_Cil.defaultCilPrinterClass.html b/cil/doc/api/type_Cil.defaultCilPrinterClass.html new file mode 100644 index 0000000..75a36eb --- /dev/null +++ b/cil/doc/api/type_Cil.defaultCilPrinterClass.html @@ -0,0 +1,25 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cil.defaultCilPrinterClass + + +Cil.cilPrinter \ No newline at end of file diff --git a/cil/doc/api/type_Cil.html b/cil/doc/api/type_Cil.html new file mode 100644 index 0000000..da6f9e9 --- /dev/null +++ b/cil/doc/api/type_Cil.html @@ -0,0 +1,622 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cil + + +sig
+  val initCIL : unit -> unit
+  val cilVersion : string
+  val cilVersionMajor : int
+  val cilVersionMinor : int
+  val cilVersionRevision : int
+  type file = {
+    mutable fileName : string;
+    mutable globals : Cil.global list;
+    mutable globinit : Cil.fundec option;
+    mutable globinitcalled : bool;
+  }
+  and comment = Cil.location * string
+  and global =
+      GType of Cil.typeinfo * Cil.location
+    | GCompTag of Cil.compinfo * Cil.location
+    | GCompTagDecl of Cil.compinfo * Cil.location
+    | GEnumTag of Cil.enuminfo * Cil.location
+    | GEnumTagDecl of Cil.enuminfo * Cil.location
+    | GVarDecl of Cil.varinfo * Cil.location
+    | GVar of Cil.varinfo * Cil.initinfo * Cil.location
+    | GFun of Cil.fundec * Cil.location
+    | GAsm of string * Cil.location
+    | GPragma of Cil.attribute * Cil.location
+    | GText of string
+  and typ =
+      TVoid of Cil.attributes
+    | TInt of Cil.ikind * Cil.attributes
+    | TFloat of Cil.fkind * Cil.attributes
+    | TPtr of Cil.typ * Cil.attributes
+    | TArray of Cil.typ * Cil.exp option * Cil.attributes
+    | TFun of Cil.typ * (string * Cil.typ * Cil.attributes) list option *
+        bool * Cil.attributes
+    | TNamed of Cil.typeinfo * Cil.attributes
+    | TComp of Cil.compinfo * Cil.attributes
+    | TEnum of Cil.enuminfo * Cil.attributes
+    | TBuiltin_va_list of Cil.attributes
+  and ikind =
+      IChar
+    | ISChar
+    | IUChar
+    | IInt
+    | IUInt
+    | IShort
+    | IUShort
+    | ILong
+    | IULong
+    | ILongLong
+    | IULongLong
+  and fkind = FFloat | FDouble | FLongDouble
+  and attribute = Attr of string * Cil.attrparam list
+  and attributes = Cil.attribute list
+  and attrparam =
+      AInt of int
+    | AStr of string
+    | ACons of string * Cil.attrparam list
+    | ASizeOf of Cil.typ
+    | ASizeOfE of Cil.attrparam
+    | ASizeOfS of Cil.typsig
+    | AAlignOf of Cil.typ
+    | AAlignOfE of Cil.attrparam
+    | AAlignOfS of Cil.typsig
+    | AUnOp of Cil.unop * Cil.attrparam
+    | ABinOp of Cil.binop * Cil.attrparam * Cil.attrparam
+    | ADot of Cil.attrparam * string
+  and compinfo = {
+    mutable cstruct : bool;
+    mutable cname : string;
+    mutable ckey : int;
+    mutable cfields : Cil.fieldinfo list;
+    mutable cattr : Cil.attributes;
+    mutable cdefined : bool;
+    mutable creferenced : bool;
+  }
+  and fieldinfo = {
+    mutable fcomp : Cil.compinfo;
+    mutable fname : string;
+    mutable ftype : Cil.typ;
+    mutable fbitfield : int option;
+    mutable fattr : Cil.attributes;
+    mutable floc : Cil.location;
+  }
+  and enuminfo = {
+    mutable ename : string;
+    mutable eitems : (string * Cil.exp * Cil.location) list;
+    mutable eattr : Cil.attributes;
+    mutable ereferenced : bool;
+  }
+  and typeinfo = {
+    mutable tname : string;
+    mutable ttype : Cil.typ;
+    mutable treferenced : bool;
+  }
+  and varinfo = {
+    mutable vname : string;
+    mutable vtype : Cil.typ;
+    mutable vattr : Cil.attributes;
+    mutable vstorage : Cil.storage;
+    mutable vglob : bool;
+    mutable vinline : bool;
+    mutable vdecl : Cil.location;
+    mutable vid : int;
+    mutable vaddrof : bool;
+    mutable vreferenced : bool;
+  }
+  and storage = NoStorage | Static | Register | Extern
+  and exp =
+      Const of Cil.constant
+    | Lval of Cil.lval
+    | SizeOf of Cil.typ
+    | SizeOfE of Cil.exp
+    | SizeOfStr of string
+    | AlignOf of Cil.typ
+    | AlignOfE of Cil.exp
+    | UnOp of Cil.unop * Cil.exp * Cil.typ
+    | BinOp of Cil.binop * Cil.exp * Cil.exp * Cil.typ
+    | CastE of Cil.typ * Cil.exp
+    | AddrOf of Cil.lval
+    | StartOf of Cil.lval
+  and constant =
+      CInt64 of int64 * Cil.ikind * string option
+    | CStr of string
+    | CWStr of int64 list
+    | CChr of char
+    | CReal of float * Cil.fkind * string option
+    | CEnum of Cil.exp * string * Cil.enuminfo
+  and unop = Neg | BNot | LNot
+  and binop =
+      PlusA
+    | PlusPI
+    | IndexPI
+    | MinusA
+    | MinusPI
+    | MinusPP
+    | Mult
+    | Div
+    | Mod
+    | Shiftlt
+    | Shiftrt
+    | Lt
+    | Gt
+    | Le
+    | Ge
+    | Eq
+    | Ne
+    | BAnd
+    | BXor
+    | BOr
+    | LAnd
+    | LOr
+  and lval = Cil.lhost * Cil.offset
+  and lhost = Var of Cil.varinfo | Mem of Cil.exp
+  and offset =
+      NoOffset
+    | Field of Cil.fieldinfo * Cil.offset
+    | Index of Cil.exp * Cil.offset
+  and init =
+      SingleInit of Cil.exp
+    | CompoundInit of Cil.typ * (Cil.offset * Cil.init) list
+  and initinfo = { mutable init : Cil.init option; }
+  and fundec = {
+    mutable svar : Cil.varinfo;
+    mutable sformals : Cil.varinfo list;
+    mutable slocals : Cil.varinfo list;
+    mutable smaxid : int;
+    mutable sbody : Cil.block;
+    mutable smaxstmtid : int option;
+    mutable sallstmts : Cil.stmt list;
+  }
+  and block = {
+    mutable battrs : Cil.attributes;
+    mutable bstmts : Cil.stmt list;
+  }
+  and stmt = {
+    mutable labels : Cil.label list;
+    mutable skind : Cil.stmtkind;
+    mutable sid : int;
+    mutable succs : Cil.stmt list;
+    mutable preds : Cil.stmt list;
+  }
+  and label =
+      Label of string * Cil.location * bool
+    | Case of Cil.exp * Cil.location
+    | Default of Cil.location
+  and stmtkind =
+      Instr of Cil.instr list
+    | Return of Cil.exp option * Cil.location
+    | Goto of Cil.stmt Pervasives.ref * Cil.location
+    | Break of Cil.location
+    | Continue of Cil.location
+    | If of Cil.exp * Cil.block * Cil.block * Cil.location
+    | Switch of Cil.exp * Cil.block * Cil.stmt list * Cil.location
+    | Loop of Cil.block * Cil.location * Cil.stmt option * Cil.stmt option
+    | Block of Cil.block
+    | TryFinally of Cil.block * Cil.block * Cil.location
+    | TryExcept of Cil.block * (Cil.instr list * Cil.exp) * Cil.block *
+        Cil.location
+  and instr =
+      Set of Cil.lval * Cil.exp * Cil.location
+    | Call of Cil.lval option * Cil.exp * Cil.exp list * Cil.location
+    | Asm of Cil.attributes * string list * (string * Cil.lval) list *
+        (string * Cil.exp) list * string list * Cil.location
+  and location = { line : int; file : string; byte : int; }
+  and typsig =
+      TSArray of Cil.typsig * int64 option * Cil.attribute list
+    | TSPtr of Cil.typsig * Cil.attribute list
+    | TSComp of bool * string * Cil.attribute list
+    | TSFun of Cil.typsig * Cil.typsig list * bool * Cil.attribute list
+    | TSEnum of string * Cil.attribute list
+    | TSBase of Cil.typ
+  val lowerConstants : bool ref
+  val insertImplicitCasts : bool Pervasives.ref
+  type featureDescr = {
+    fd_enabled : bool Pervasives.ref;
+    fd_name : string;
+    fd_description : string;
+    fd_extraopt : (string * Arg.spec * string) list;
+    fd_doit : Cil.file -> unit;
+    fd_post_check : bool;
+  }
+  val compareLoc : Cil.location -> Cil.location -> int
+  val emptyFunction : string -> Cil.fundec
+  val setFormals : Cil.fundec -> Cil.varinfo list -> unit
+  val setFunctionType : Cil.fundec -> Cil.typ -> unit
+  val setFunctionTypeMakeFormals : Cil.fundec -> Cil.typ -> unit
+  val setMaxId : Cil.fundec -> unit
+  val dummyFunDec : Cil.fundec
+  val dummyFile : Cil.file
+  val saveBinaryFile : Cil.file -> string -> unit
+  val saveBinaryFileChannel : Cil.file -> Pervasives.out_channel -> unit
+  val loadBinaryFile : string -> Cil.file
+  val getGlobInit : ?main_name:string -> Cil.file -> Cil.fundec
+  val iterGlobals : Cil.file -> (Cil.global -> unit) -> unit
+  val foldGlobals : Cil.file -> ('a -> Cil.global -> 'a) -> 'a -> 'a
+  val mapGlobals : Cil.file -> (Cil.global -> Cil.global) -> unit
+  val new_sid : unit -> int
+  val prepareCFG : Cil.fundec -> unit
+  val computeCFGInfo : Cil.fundec -> bool -> unit
+  val copyFunction : Cil.fundec -> string -> Cil.fundec
+  val pushGlobal :
+    Cil.global ->
+    types:Cil.global list Pervasives.ref ->
+    variables:Cil.global list Pervasives.ref -> unit
+  val invalidStmt : Cil.stmt
+  val gccBuiltins : (string, Cil.typ * Cil.typ list * bool) Hashtbl.t
+  val msvcBuiltins : (string, Cil.typ * Cil.typ list * bool) Hashtbl.t
+  val makeZeroInit : Cil.typ -> Cil.init
+  val foldLeftCompound :
+    doinit:(Cil.offset -> Cil.init -> Cil.typ -> 'a -> 'a) ->
+    ct:Cil.typ -> initl:(Cil.offset * Cil.init) list -> acc:'a -> 'a
+  val foldLeftCompoundAll :
+    doinit:(Cil.offset -> Cil.init -> Cil.typ -> 'a -> 'a) ->
+    ct:Cil.typ -> initl:(Cil.offset * Cil.init) list -> acc:'a -> 'a
+  val voidType : Cil.typ
+  val isVoidType : Cil.typ -> bool
+  val isVoidPtrType : Cil.typ -> bool
+  val intType : Cil.typ
+  val uintType : Cil.typ
+  val longType : Cil.typ
+  val ulongType : Cil.typ
+  val charType : Cil.typ
+  val charPtrType : Cil.typ
+  val wcharKind : Cil.ikind Pervasives.ref
+  val wcharType : Cil.typ Pervasives.ref
+  val charConstPtrType : Cil.typ
+  val voidPtrType : Cil.typ
+  val intPtrType : Cil.typ
+  val uintPtrType : Cil.typ
+  val doubleType : Cil.typ
+  val upointType : Cil.typ Pervasives.ref
+  val typeOfSizeOf : Cil.typ Pervasives.ref
+  val isSigned : Cil.ikind -> bool
+  val mkCompInfo :
+    bool ->
+    string ->
+    (Cil.compinfo ->
+     (string * Cil.typ * int option * Cil.attributes * Cil.location) list) ->
+    Cil.attributes -> Cil.compinfo
+  val copyCompInfo : Cil.compinfo -> string -> Cil.compinfo
+  val missingFieldName : string
+  val compFullName : Cil.compinfo -> string
+  val isCompleteType : Cil.typ -> bool
+  val unrollType : Cil.typ -> Cil.typ
+  val unrollTypeDeep : Cil.typ -> Cil.typ
+  val separateStorageModifiers :
+    Cil.attribute list -> Cil.attribute list * Cil.attribute list
+  val isIntegralType : Cil.typ -> bool
+  val isArithmeticType : Cil.typ -> bool
+  val isPointerType : Cil.typ -> bool
+  val isFunctionType : Cil.typ -> bool
+  val argsToList :
+    (string * Cil.typ * Cil.attributes) list option ->
+    (string * Cil.typ * Cil.attributes) list
+  val isArrayType : Cil.typ -> bool
+  exception LenOfArray
+  val lenOfArray : Cil.exp option -> int
+  val getCompField : Cil.compinfo -> string -> Cil.fieldinfo
+  type existsAction = ExistsTrue | ExistsFalse | ExistsMaybe
+  val existsType : (Cil.typ -> Cil.existsAction) -> Cil.typ -> bool
+  val splitFunctionType :
+    Cil.typ ->
+    Cil.typ * (string * Cil.typ * Cil.attributes) list option * bool *
+    Cil.attributes
+  val splitFunctionTypeVI :
+    Cil.varinfo ->
+    Cil.typ * (string * Cil.typ * Cil.attributes) list option * bool *
+    Cil.attributes
+  val d_typsig : unit -> Cil.typsig -> Pretty.doc
+  val typeSig : Cil.typ -> Cil.typsig
+  val typeSigWithAttrs :
+    ?ignoreSign:bool ->
+    (Cil.attributes -> Cil.attributes) -> Cil.typ -> Cil.typsig
+  val setTypeSigAttrs : Cil.attributes -> Cil.typsig -> Cil.typsig
+  val typeSigAttrs : Cil.typsig -> Cil.attributes
+  val makeVarinfo : bool -> string -> Cil.typ -> Cil.varinfo
+  val makeFormalVar :
+    Cil.fundec -> ?where:string -> string -> Cil.typ -> Cil.varinfo
+  val makeLocalVar :
+    Cil.fundec -> ?insert:bool -> string -> Cil.typ -> Cil.varinfo
+  val makeTempVar : Cil.fundec -> ?name:string -> Cil.typ -> Cil.varinfo
+  val makeGlobalVar : string -> Cil.typ -> Cil.varinfo
+  val copyVarinfo : Cil.varinfo -> string -> Cil.varinfo
+  val newVID : unit -> int
+  val addOffsetLval : Cil.offset -> Cil.lval -> Cil.lval
+  val addOffset : Cil.offset -> Cil.offset -> Cil.offset
+  val removeOffsetLval : Cil.lval -> Cil.lval * Cil.offset
+  val removeOffset : Cil.offset -> Cil.offset * Cil.offset
+  val typeOfLval : Cil.lval -> Cil.typ
+  val typeOffset : Cil.typ -> Cil.offset -> Cil.typ
+  val zero : Cil.exp
+  val one : Cil.exp
+  val mone : Cil.exp
+  val kinteger64 : Cil.ikind -> int64 -> Cil.exp
+  val kinteger : Cil.ikind -> int -> Cil.exp
+  val integer : int -> Cil.exp
+  val isInteger : Cil.exp -> int64 option
+  val isConstant : Cil.exp -> bool
+  val isZero : Cil.exp -> bool
+  val charConstToInt : char -> Cil.constant
+  val constFold : bool -> Cil.exp -> Cil.exp
+  val constFoldBinOp :
+    bool -> Cil.binop -> Cil.exp -> Cil.exp -> Cil.typ -> Cil.exp
+  val increm : Cil.exp -> int -> Cil.exp
+  val var : Cil.varinfo -> Cil.lval
+  val mkAddrOf : Cil.lval -> Cil.exp
+  val mkAddrOrStartOf : Cil.lval -> Cil.exp
+  val mkMem : addr:Cil.exp -> off:Cil.offset -> Cil.lval
+  val mkString : string -> Cil.exp
+  val mkCastT : e:Cil.exp -> oldt:Cil.typ -> newt:Cil.typ -> Cil.exp
+  val mkCast : e:Cil.exp -> newt:Cil.typ -> Cil.exp
+  val stripCasts : Cil.exp -> Cil.exp
+  val typeOf : Cil.exp -> Cil.typ
+  val parseInt : string -> Cil.exp
+  val mkStmt : Cil.stmtkind -> Cil.stmt
+  val mkBlock : Cil.stmt list -> Cil.block
+  val mkStmtOneInstr : Cil.instr -> Cil.stmt
+  val compactStmts : Cil.stmt list -> Cil.stmt list
+  val mkEmptyStmt : unit -> Cil.stmt
+  val dummyInstr : Cil.instr
+  val dummyStmt : Cil.stmt
+  val mkWhile : guard:Cil.exp -> body:Cil.stmt list -> Cil.stmt list
+  val mkForIncr :
+    iter:Cil.varinfo ->
+    first:Cil.exp ->
+    stopat:Cil.exp -> incr:Cil.exp -> body:Cil.stmt list -> Cil.stmt list
+  val mkFor :
+    start:Cil.stmt list ->
+    guard:Cil.exp ->
+    next:Cil.stmt list -> body:Cil.stmt list -> Cil.stmt list
+  type attributeClass = AttrName of bool | AttrFunType of bool | AttrType
+  val attributeHash : (string, Cil.attributeClass) Hashtbl.t
+  val partitionAttributes :
+    default:Cil.attributeClass ->
+    Cil.attributes ->
+    Cil.attribute list * Cil.attribute list * Cil.attribute list
+  val addAttribute : Cil.attribute -> Cil.attributes -> Cil.attributes
+  val addAttributes : Cil.attribute list -> Cil.attributes -> Cil.attributes
+  val dropAttribute : string -> Cil.attributes -> Cil.attributes
+  val dropAttributes : string list -> Cil.attributes -> Cil.attributes
+  val filterAttributes : string -> Cil.attributes -> Cil.attributes
+  val hasAttribute : string -> Cil.attributes -> bool
+  val typeAttrs : Cil.typ -> Cil.attribute list
+  val setTypeAttrs : Cil.typ -> Cil.attributes -> Cil.typ
+  val typeAddAttributes : Cil.attribute list -> Cil.typ -> Cil.typ
+  val typeRemoveAttributes : string list -> Cil.typ -> Cil.typ
+  type 'a visitAction =
+      SkipChildren
+    | DoChildren
+    | ChangeTo of 'a
+    | ChangeDoChildrenPost of 'a * ('a -> 'a)
+  class type cilVisitor =
+    object
+      method queueInstr : Cil.instr list -> unit
+      method unqueueInstr : unit -> Cil.instr list
+      method vattr : Cil.attribute -> Cil.attribute list Cil.visitAction
+      method vattrparam : Cil.attrparam -> Cil.attrparam Cil.visitAction
+      method vblock : Cil.block -> Cil.block Cil.visitAction
+      method vexpr : Cil.exp -> Cil.exp Cil.visitAction
+      method vfunc : Cil.fundec -> Cil.fundec Cil.visitAction
+      method vglob : Cil.global -> Cil.global list Cil.visitAction
+      method vinit : Cil.init -> Cil.init Cil.visitAction
+      method vinitoffs : Cil.offset -> Cil.offset Cil.visitAction
+      method vinst : Cil.instr -> Cil.instr list Cil.visitAction
+      method vlval : Cil.lval -> Cil.lval Cil.visitAction
+      method voffs : Cil.offset -> Cil.offset Cil.visitAction
+      method vstmt : Cil.stmt -> Cil.stmt Cil.visitAction
+      method vtype : Cil.typ -> Cil.typ Cil.visitAction
+      method vvdec : Cil.varinfo -> Cil.varinfo Cil.visitAction
+      method vvrbl : Cil.varinfo -> Cil.varinfo Cil.visitAction
+    end
+  class nopCilVisitor : cilVisitor
+  val visitCilFile : Cil.cilVisitor -> Cil.file -> unit
+  val visitCilFileSameGlobals : Cil.cilVisitor -> Cil.file -> unit
+  val visitCilGlobal : Cil.cilVisitor -> Cil.global -> Cil.global list
+  val visitCilFunction : Cil.cilVisitor -> Cil.fundec -> Cil.fundec
+  val visitCilExpr : Cil.cilVisitor -> Cil.exp -> Cil.exp
+  val visitCilLval : Cil.cilVisitor -> Cil.lval -> Cil.lval
+  val visitCilOffset : Cil.cilVisitor -> Cil.offset -> Cil.offset
+  val visitCilInitOffset : Cil.cilVisitor -> Cil.offset -> Cil.offset
+  val visitCilInstr : Cil.cilVisitor -> Cil.instr -> Cil.instr list
+  val visitCilStmt : Cil.cilVisitor -> Cil.stmt -> Cil.stmt
+  val visitCilBlock : Cil.cilVisitor -> Cil.block -> Cil.block
+  val visitCilType : Cil.cilVisitor -> Cil.typ -> Cil.typ
+  val visitCilVarDecl : Cil.cilVisitor -> Cil.varinfo -> Cil.varinfo
+  val visitCilInit : Cil.cilVisitor -> Cil.init -> Cil.init
+  val visitCilAttributes :
+    Cil.cilVisitor -> Cil.attribute list -> Cil.attribute list
+  val msvcMode : bool Pervasives.ref
+  val useLogicalOperators : bool Pervasives.ref
+  val constFoldVisitor : bool -> Cil.cilVisitor
+  type lineDirectiveStyle =
+      LineComment
+    | LinePreprocessorInput
+    | LinePreprocessorOutput
+  val lineDirectiveStyle : Cil.lineDirectiveStyle option Pervasives.ref
+  val print_CIL_Input : bool Pervasives.ref
+  val printCilAsIs : bool Pervasives.ref
+  val lineLength : int Pervasives.ref
+  val forgcc : string -> string
+  val currentLoc : Cil.location Pervasives.ref
+  val currentGlobal : Cil.global Pervasives.ref
+  val d_loc : unit -> Cil.location -> Pretty.doc
+  val d_thisloc : unit -> Pretty.doc
+  val d_ikind : unit -> Cil.ikind -> Pretty.doc
+  val d_fkind : unit -> Cil.fkind -> Pretty.doc
+  val d_storage : unit -> Cil.storage -> Pretty.doc
+  val d_const : unit -> Cil.constant -> Pretty.doc
+  val derefStarLevel : int
+  val indexLevel : int
+  val arrowLevel : int
+  val addrOfLevel : int
+  val additiveLevel : int
+  val comparativeLevel : int
+  val bitwiseLevel : int
+  val getParenthLevel : Cil.exp -> int
+  class type cilPrinter =
+    object
+      method dBlock : Pervasives.out_channel -> int -> Cil.block -> unit
+      method dGlobal : Pervasives.out_channel -> Cil.global -> unit
+      method dInit : Pervasives.out_channel -> int -> Cil.init -> unit
+      method dStmt : Pervasives.out_channel -> int -> Cil.stmt -> unit
+      method pAttr : Cil.attribute -> Pretty.doc * bool
+      method pAttrParam : unit -> Cil.attrparam -> Pretty.doc
+      method pAttrs : unit -> Cil.attributes -> Pretty.doc
+      method pBlock : unit -> Cil.block -> Pretty.doc
+      method pExp : unit -> Cil.exp -> Pretty.doc
+      method pFieldDecl : unit -> Cil.fieldinfo -> Pretty.doc
+      method pGlobal : unit -> Cil.global -> Pretty.doc
+      method pInit : unit -> Cil.init -> Pretty.doc
+      method pInstr : unit -> Cil.instr -> Pretty.doc
+      method pLabel : unit -> Cil.label -> Pretty.doc
+      method pLineDirective : ?forcefile:bool -> Cil.location -> Pretty.doc
+      method pLval : unit -> Cil.lval -> Pretty.doc
+      method pOffset : Pretty.doc -> Cil.offset -> Pretty.doc
+      method pStmt : unit -> Cil.stmt -> Pretty.doc
+      method pStmtKind : Cil.stmt -> unit -> Cil.stmtkind -> Pretty.doc
+      method pType : Pretty.doc option -> unit -> Cil.typ -> Pretty.doc
+      method pVDecl : unit -> Cil.varinfo -> Pretty.doc
+      method pVar : Cil.varinfo -> Pretty.doc
+    end
+  class defaultCilPrinterClass : cilPrinter
+  val defaultCilPrinter : Cil.cilPrinter
+  class plainCilPrinterClass : cilPrinter
+  val plainCilPrinter : Cil.cilPrinter
+  val printerForMaincil : Cil.cilPrinter Pervasives.ref
+  val printType : Cil.cilPrinter -> unit -> Cil.typ -> Pretty.doc
+  val printExp : Cil.cilPrinter -> unit -> Cil.exp -> Pretty.doc
+  val printLval : Cil.cilPrinter -> unit -> Cil.lval -> Pretty.doc
+  val printGlobal : Cil.cilPrinter -> unit -> Cil.global -> Pretty.doc
+  val printAttr : Cil.cilPrinter -> unit -> Cil.attribute -> Pretty.doc
+  val printAttrs : Cil.cilPrinter -> unit -> Cil.attributes -> Pretty.doc
+  val printInstr : Cil.cilPrinter -> unit -> Cil.instr -> Pretty.doc
+  val printStmt : Cil.cilPrinter -> unit -> Cil.stmt -> Pretty.doc
+  val printBlock : Cil.cilPrinter -> unit -> Cil.block -> Pretty.doc
+  val dumpStmt :
+    Cil.cilPrinter -> Pervasives.out_channel -> int -> Cil.stmt -> unit
+  val dumpBlock :
+    Cil.cilPrinter -> Pervasives.out_channel -> int -> Cil.block -> unit
+  val printInit : Cil.cilPrinter -> unit -> Cil.init -> Pretty.doc
+  val dumpInit :
+    Cil.cilPrinter -> Pervasives.out_channel -> int -> Cil.init -> unit
+  val d_type : unit -> Cil.typ -> Pretty.doc
+  val d_exp : unit -> Cil.exp -> Pretty.doc
+  val d_lval : unit -> Cil.lval -> Pretty.doc
+  val d_offset : Pretty.doc -> unit -> Cil.offset -> Pretty.doc
+  val d_init : unit -> Cil.init -> Pretty.doc
+  val d_binop : unit -> Cil.binop -> Pretty.doc
+  val d_unop : unit -> Cil.unop -> Pretty.doc
+  val d_attr : unit -> Cil.attribute -> Pretty.doc
+  val d_attrparam : unit -> Cil.attrparam -> Pretty.doc
+  val d_attrlist : unit -> Cil.attributes -> Pretty.doc
+  val d_instr : unit -> Cil.instr -> Pretty.doc
+  val d_label : unit -> Cil.label -> Pretty.doc
+  val d_stmt : unit -> Cil.stmt -> Pretty.doc
+  val d_block : unit -> Cil.block -> Pretty.doc
+  val d_global : unit -> Cil.global -> Pretty.doc
+  val dn_exp : unit -> Cil.exp -> Pretty.doc
+  val dn_lval : unit -> Cil.lval -> Pretty.doc
+  val dn_init : unit -> Cil.init -> Pretty.doc
+  val dn_type : unit -> Cil.typ -> Pretty.doc
+  val dn_global : unit -> Cil.global -> Pretty.doc
+  val dn_attrlist : unit -> Cil.attributes -> Pretty.doc
+  val dn_attr : unit -> Cil.attribute -> Pretty.doc
+  val dn_attrparam : unit -> Cil.attrparam -> Pretty.doc
+  val dn_stmt : unit -> Cil.stmt -> Pretty.doc
+  val dn_instr : unit -> Cil.instr -> Pretty.doc
+  val d_shortglobal : unit -> Cil.global -> Pretty.doc
+  val dumpGlobal :
+    Cil.cilPrinter -> Pervasives.out_channel -> Cil.global -> unit
+  val dumpFile :
+    Cil.cilPrinter -> Pervasives.out_channel -> string -> Cil.file -> unit
+  val bug : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+  val unimp : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+  val error : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+  val errorLoc :
+    Cil.location -> ('a, unit, Pretty.doc) Pervasives.format -> 'a
+  val warn : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+  val warnOpt : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+  val warnContext : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+  val warnContextOpt : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+  val warnLoc :
+    Cil.location -> ('a, unit, Pretty.doc) Pervasives.format -> 'a
+  val d_plainexp : unit -> Cil.exp -> Pretty.doc
+  val d_plaininit : unit -> Cil.init -> Pretty.doc
+  val d_plainlval : unit -> Cil.lval -> Pretty.doc
+  val d_plaintype : unit -> Cil.typ -> Pretty.doc
+  val uniqueVarNames : Cil.file -> unit
+  val peepHole2 :
+    (Cil.instr * Cil.instr -> Cil.instr list option) -> Cil.stmt list -> unit
+  val peepHole1 :
+    (Cil.instr -> Cil.instr list option) -> Cil.stmt list -> unit
+  exception SizeOfError of string * Cil.typ
+  val bitsSizeOf : Cil.typ -> int
+  val sizeOf : Cil.typ -> Cil.exp
+  val alignOf_int : Cil.typ -> int
+  val bitsOffset : Cil.typ -> Cil.offset -> int * int
+  val char_is_unsigned : bool Pervasives.ref
+  val little_endian : bool Pervasives.ref
+  val underscore_name : bool Pervasives.ref
+  val locUnknown : Cil.location
+  val get_instrLoc : Cil.instr -> Cil.location
+  val get_globalLoc : Cil.global -> Cil.location
+  val get_stmtLoc : Cil.stmtkind -> Cil.location
+  val dExp : Pretty.doc -> Cil.exp
+  val dInstr : Pretty.doc -> Cil.location -> Cil.instr
+  val dGlobal : Pretty.doc -> Cil.location -> Cil.global
+  val mapNoCopy : ('a -> 'a) -> 'a list -> 'a list
+  val mapNoCopyList : ('a -> 'a list) -> 'a list -> 'a list
+  val startsWith : string -> string -> bool
+  type formatArg =
+      Fe of Cil.exp
+    | Feo of Cil.exp option
+    | Fu of Cil.unop
+    | Fb of Cil.binop
+    | Fk of Cil.ikind
+    | FE of Cil.exp list
+    | Ff of (string * Cil.typ * Cil.attributes)
+    | FF of (string * Cil.typ * Cil.attributes) list
+    | Fva of bool
+    | Fv of Cil.varinfo
+    | Fl of Cil.lval
+    | Flo of Cil.lval option
+    | Fo of Cil.offset
+    | Fc of Cil.compinfo
+    | Fi of Cil.instr
+    | FI of Cil.instr list
+    | Ft of Cil.typ
+    | Fd of int
+    | Fg of string
+    | Fs of Cil.stmt
+    | FS of Cil.stmt list
+    | FA of Cil.attributes
+    | Fp of Cil.attrparam
+    | FP of Cil.attrparam list
+    | FX of string
+  val d_formatarg : unit -> Cil.formatArg -> Pretty.doc
+  val lowerConstants : bool Pervasives.ref
+end \ No newline at end of file diff --git a/cil/doc/api/type_Cil.nopCilVisitor.html b/cil/doc/api/type_Cil.nopCilVisitor.html new file mode 100644 index 0000000..0ac6c96 --- /dev/null +++ b/cil/doc/api/type_Cil.nopCilVisitor.html @@ -0,0 +1,25 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cil.nopCilVisitor + + +Cil.cilVisitor \ No newline at end of file diff --git a/cil/doc/api/type_Cil.plainCilPrinterClass.html b/cil/doc/api/type_Cil.plainCilPrinterClass.html new file mode 100644 index 0000000..ecd6317 --- /dev/null +++ b/cil/doc/api/type_Cil.plainCilPrinterClass.html @@ -0,0 +1,25 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cil.plainCilPrinterClass + + +Cil.cilPrinter \ No newline at end of file diff --git a/cil/doc/api/type_Cillower.html b/cil/doc/api/type_Cillower.html new file mode 100644 index 0000000..a8924ed --- /dev/null +++ b/cil/doc/api/type_Cillower.html @@ -0,0 +1,25 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Cillower + + +sig val lowerEnumVisitor : Cil.cilVisitor end \ No newline at end of file diff --git a/cil/doc/api/type_Clist.html b/cil/doc/api/type_Clist.html new file mode 100644 index 0000000..c7dbd02 --- /dev/null +++ b/cil/doc/api/type_Clist.html @@ -0,0 +1,44 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Clist + + +sig
+  type 'a clist =
+      CList of 'a list
+    | CConsL of 'a * 'a Clist.clist
+    | CConsR of 'a Clist.clist * 'a
+    | CSeq of 'a Clist.clist * 'a Clist.clist
+  val toList : 'a Clist.clist -> 'a list
+  val fromList : 'a list -> 'a Clist.clist
+  val single : 'a -> 'a Clist.clist
+  val empty : 'a Clist.clist
+  val append : 'a Clist.clist -> 'a Clist.clist -> 'a Clist.clist
+  val checkBeforeAppend : 'a Clist.clist -> 'a Clist.clist -> bool
+  val length : 'a Clist.clist -> int
+  val map : ('a -> 'b) -> 'a Clist.clist -> 'b Clist.clist
+  val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b Clist.clist -> 'a
+  val iter : ('a -> unit) -> 'a Clist.clist -> unit
+  val rev : ('a -> 'a) -> 'a Clist.clist -> 'a Clist.clist
+  val docCList :
+    Pretty.doc -> ('a -> Pretty.doc) -> unit -> 'a Clist.clist -> Pretty.doc
+end \ No newline at end of file diff --git a/cil/doc/api/type_Dataflow.BackwardsDataFlow.html b/cil/doc/api/type_Dataflow.BackwardsDataFlow.html new file mode 100644 index 0000000..78ffeba --- /dev/null +++ b/cil/doc/api/type_Dataflow.BackwardsDataFlow.html @@ -0,0 +1,26 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Dataflow.BackwardsDataFlow + + +functor (T : BackwardsTransfer) ->
+  sig val compute : Cil.stmt list -> unit end \ No newline at end of file diff --git a/cil/doc/api/type_Dataflow.BackwardsTransfer.html b/cil/doc/api/type_Dataflow.BackwardsTransfer.html new file mode 100644 index 0000000..763df74 --- /dev/null +++ b/cil/doc/api/type_Dataflow.BackwardsTransfer.html @@ -0,0 +1,44 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Dataflow.BackwardsTransfer + + +sig
+  val name : string
+  val debug : bool Pervasives.ref
+  type t
+  val pretty : unit -> Dataflow.BackwardsTransfer.t -> Pretty.doc
+  val stmtStartData : Dataflow.BackwardsTransfer.t Inthash.t
+  val combineStmtStartData :
+    Cil.stmt ->
+    old:Dataflow.BackwardsTransfer.t ->
+    Dataflow.BackwardsTransfer.t -> Dataflow.BackwardsTransfer.t option
+  val combineSuccessors :
+    Dataflow.BackwardsTransfer.t ->
+    Dataflow.BackwardsTransfer.t -> Dataflow.BackwardsTransfer.t
+  val doStmt : Cil.stmt -> Dataflow.BackwardsTransfer.t Dataflow.action
+  val doInstr :
+    Cil.instr ->
+    Dataflow.BackwardsTransfer.t ->
+    Dataflow.BackwardsTransfer.t Dataflow.action
+  val filterStmt : Cil.stmt -> Cil.stmt -> bool
+end \ No newline at end of file diff --git a/cil/doc/api/type_Dataflow.ForwardsDataFlow.html b/cil/doc/api/type_Dataflow.ForwardsDataFlow.html new file mode 100644 index 0000000..a042cfc --- /dev/null +++ b/cil/doc/api/type_Dataflow.ForwardsDataFlow.html @@ -0,0 +1,25 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Dataflow.ForwardsDataFlow + + +functor (T : ForwardsTransfer) -> sig val compute : Cil.stmt list -> unit end \ No newline at end of file diff --git a/cil/doc/api/type_Dataflow.ForwardsTransfer.html b/cil/doc/api/type_Dataflow.ForwardsTransfer.html new file mode 100644 index 0000000..1e4d48b --- /dev/null +++ b/cil/doc/api/type_Dataflow.ForwardsTransfer.html @@ -0,0 +1,51 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Dataflow.ForwardsTransfer + + +sig
+  val name : string
+  val debug : bool Pervasives.ref
+  type t
+  val copy : Dataflow.ForwardsTransfer.t -> Dataflow.ForwardsTransfer.t
+  val stmtStartData : Dataflow.ForwardsTransfer.t Inthash.t
+  val pretty : unit -> Dataflow.ForwardsTransfer.t -> Pretty.doc
+  val computeFirstPredecessor :
+    Cil.stmt -> Dataflow.ForwardsTransfer.t -> Dataflow.ForwardsTransfer.t
+  val combinePredecessors :
+    Cil.stmt ->
+    old:Dataflow.ForwardsTransfer.t ->
+    Dataflow.ForwardsTransfer.t -> Dataflow.ForwardsTransfer.t option
+  val doInstr :
+    Cil.instr ->
+    Dataflow.ForwardsTransfer.t ->
+    Dataflow.ForwardsTransfer.t Dataflow.action
+  val doStmt :
+    Cil.stmt ->
+    Dataflow.ForwardsTransfer.t ->
+    Dataflow.ForwardsTransfer.t Dataflow.stmtaction
+  val doGuard :
+    Cil.exp ->
+    Dataflow.ForwardsTransfer.t ->
+    Dataflow.ForwardsTransfer.t Dataflow.guardaction
+  val filterStmt : Cil.stmt -> bool
+end \ No newline at end of file diff --git a/cil/doc/api/type_Dataflow.html b/cil/doc/api/type_Dataflow.html new file mode 100644 index 0000000..fa03476 --- /dev/null +++ b/cil/doc/api/type_Dataflow.html @@ -0,0 +1,85 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Dataflow + + +sig
+  type 'a action = Default | Done of 'a | Post of ('a -> 'a)
+  type 'a stmtaction = SDefault | SDone | SUse of 'a
+  type 'a guardaction = GDefault | GUse of 'a | GUnreachable
+  module type ForwardsTransfer =
+    sig
+      val name : string
+      val debug : bool Pervasives.ref
+      type t
+      val copy : Dataflow.ForwardsTransfer.t -> Dataflow.ForwardsTransfer.t
+      val stmtStartData : Dataflow.ForwardsTransfer.t Inthash.t
+      val pretty : unit -> Dataflow.ForwardsTransfer.t -> Pretty.doc
+      val computeFirstPredecessor :
+        Cil.stmt ->
+        Dataflow.ForwardsTransfer.t -> Dataflow.ForwardsTransfer.t
+      val combinePredecessors :
+        Cil.stmt ->
+        old:Dataflow.ForwardsTransfer.t ->
+        Dataflow.ForwardsTransfer.t -> Dataflow.ForwardsTransfer.t option
+      val doInstr :
+        Cil.instr ->
+        Dataflow.ForwardsTransfer.t ->
+        Dataflow.ForwardsTransfer.t Dataflow.action
+      val doStmt :
+        Cil.stmt ->
+        Dataflow.ForwardsTransfer.t ->
+        Dataflow.ForwardsTransfer.t Dataflow.stmtaction
+      val doGuard :
+        Cil.exp ->
+        Dataflow.ForwardsTransfer.t ->
+        Dataflow.ForwardsTransfer.t Dataflow.guardaction
+      val filterStmt : Cil.stmt -> bool
+    end
+  module ForwardsDataFlow :
+    functor (T : ForwardsTransfer) ->
+      sig val compute : Cil.stmt list -> unit end
+  module type BackwardsTransfer =
+    sig
+      val name : string
+      val debug : bool Pervasives.ref
+      type t
+      val pretty : unit -> Dataflow.BackwardsTransfer.t -> Pretty.doc
+      val stmtStartData : Dataflow.BackwardsTransfer.t Inthash.t
+      val combineStmtStartData :
+        Cil.stmt ->
+        old:Dataflow.BackwardsTransfer.t ->
+        Dataflow.BackwardsTransfer.t -> Dataflow.BackwardsTransfer.t option
+      val combineSuccessors :
+        Dataflow.BackwardsTransfer.t ->
+        Dataflow.BackwardsTransfer.t -> Dataflow.BackwardsTransfer.t
+      val doStmt : Cil.stmt -> Dataflow.BackwardsTransfer.t Dataflow.action
+      val doInstr :
+        Cil.instr ->
+        Dataflow.BackwardsTransfer.t ->
+        Dataflow.BackwardsTransfer.t Dataflow.action
+      val filterStmt : Cil.stmt -> Cil.stmt -> bool
+    end
+  module BackwardsDataFlow :
+    functor (T : BackwardsTransfer) ->
+      sig val compute : Cil.stmt list -> unit end
+end \ No newline at end of file diff --git a/cil/doc/api/type_Dominators.html b/cil/doc/api/type_Dominators.html new file mode 100644 index 0000000..a9fef53 --- /dev/null +++ b/cil/doc/api/type_Dominators.html @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Dominators + + +sig
+  val computeIDom : Cil.fundec -> Cil.stmt option Inthash.t
+  val getIdom : Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt option
+  val dominates : Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt -> bool
+  val findNaturalLoops :
+    Cil.fundec ->
+    Cil.stmt option Inthash.t -> (Cil.stmt * Cil.stmt list) list
+end \ No newline at end of file diff --git a/cil/doc/api/type_Errormsg.html b/cil/doc/api/type_Errormsg.html new file mode 100644 index 0000000..3ad0a86 --- /dev/null +++ b/cil/doc/api/type_Errormsg.html @@ -0,0 +1,64 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Errormsg + + +sig
+  val logChannel : Pervasives.out_channel Pervasives.ref
+  val debugFlag : bool Pervasives.ref
+  val verboseFlag : bool Pervasives.ref
+  val warnFlag : bool Pervasives.ref
+  exception Error
+  val error : ('a, unit, Pretty.doc, unit) format4 -> 'a
+  val bug : ('a, unit, Pretty.doc, unit) format4 -> 'a
+  val unimp : ('a, unit, Pretty.doc, unit) format4 -> 'a
+  val s : 'a -> 'b
+  val hadErrors : bool Pervasives.ref
+  val warn : ('a, unit, Pretty.doc, unit) format4 -> 'a
+  val warnOpt : ('a, unit, Pretty.doc, unit) format4 -> 'a
+  val log : ('a, unit, Pretty.doc, unit) format4 -> 'a
+  val logg : ('a, unit, Pretty.doc, unit) format4 -> 'a
+  val null : ('a, unit, Pretty.doc, unit) format4 -> 'a
+  val pushContext : (unit -> Pretty.doc) -> unit
+  val popContext : unit -> unit
+  val showContext : unit -> unit
+  val withContext : (unit -> Pretty.doc) -> ('a -> 'b) -> 'a -> 'b
+  val newline : unit -> unit
+  val newHline : unit -> unit
+  val getPosition : unit -> int * string * int
+  val getHPosition : unit -> int * string
+  val setHLine : int -> unit
+  val setHFile : string -> unit
+  val setCurrentLine : int -> unit
+  val setCurrentFile : string -> unit
+  type location = { file : string; line : int; hfile : string; hline : int; }
+  val d_loc : unit -> Errormsg.location -> Pretty.doc
+  val d_hloc : unit -> Errormsg.location -> Pretty.doc
+  val getLocation : unit -> Errormsg.location
+  val parse_error : string -> 'a
+  val locUnknown : Errormsg.location
+  val readingFromStdin : bool Pervasives.ref
+  val startParsing : ?useBasename:bool -> string -> Lexing.lexbuf
+  val startParsingFromString :
+    ?file:string -> ?line:int -> string -> Lexing.lexbuf
+  val finishParsing : unit -> unit
+end \ No newline at end of file diff --git a/cil/doc/api/type_Formatcil.html b/cil/doc/api/type_Formatcil.html new file mode 100644 index 0000000..7c5139b --- /dev/null +++ b/cil/doc/api/type_Formatcil.html @@ -0,0 +1,45 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Formatcil + + +sig
+  val cExp : string -> (string * Cil.formatArg) list -> Cil.exp
+  val cLval : string -> (string * Cil.formatArg) list -> Cil.lval
+  val cType : string -> (string * Cil.formatArg) list -> Cil.typ
+  val cInstr :
+    string -> Cil.location -> (string * Cil.formatArg) list -> Cil.instr
+  val cStmt :
+    string ->
+    (string -> Cil.typ -> Cil.varinfo) ->
+    Cil.location -> (string * Cil.formatArg) list -> Cil.stmt
+  val cStmts :
+    string ->
+    (string -> Cil.typ -> Cil.varinfo) ->
+    Cil.location -> (string * Cil.formatArg) list -> Cil.stmt list
+  val dExp : string -> Cil.exp -> Cil.formatArg list option
+  val dLval : string -> Cil.lval -> Cil.formatArg list option
+  val dType : string -> Cil.typ -> Cil.formatArg list option
+  val dInstr : string -> Cil.instr -> Cil.formatArg list option
+  val noMemoize : bool Pervasives.ref
+  val test : unit -> unit
+end \ No newline at end of file diff --git a/cil/doc/api/type_Pretty.MakeMapPrinter.html b/cil/doc/api/type_Pretty.MakeMapPrinter.html new file mode 100644 index 0000000..0b9d35e --- /dev/null +++ b/cil/doc/api/type_Pretty.MakeMapPrinter.html @@ -0,0 +1,42 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Pretty.MakeMapPrinter + + +functor
+  (Map : sig
+           type key
+           type 'a t
+           val fold :
+             (Pretty.MakeMapPrinter.key -> 'a -> 'b -> 'b) ->
+             'a Pretty.MakeMapPrinter.t -> 'b -> 'b
+         end) ->
+  sig
+    val docMap :
+      ?sep:Pretty.doc ->
+      (Map.key -> 'a -> Pretty.doc) -> unit -> 'a Map.t -> Pretty.doc
+    val d_map :
+      ?dmaplet:(Pretty.doc -> Pretty.doc -> Pretty.doc) ->
+      string ->
+      (unit -> Map.key -> Pretty.doc) ->
+      (unit -> 'a -> Pretty.doc) -> unit -> 'a Map.t -> Pretty.doc
+  end \ No newline at end of file diff --git a/cil/doc/api/type_Pretty.MakeSetPrinter.html b/cil/doc/api/type_Pretty.MakeSetPrinter.html new file mode 100644 index 0000000..c5e0466 --- /dev/null +++ b/cil/doc/api/type_Pretty.MakeSetPrinter.html @@ -0,0 +1,40 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Pretty.MakeSetPrinter + + +functor
+  (Set : sig
+           type elt
+           type t
+           val fold :
+             (Pretty.MakeSetPrinter.elt -> 'a -> 'a) ->
+             Pretty.MakeSetPrinter.t -> 'a -> 'a
+         end) ->
+  sig
+    val docSet :
+      ?sep:Pretty.doc ->
+      (Set.elt -> Pretty.doc) -> unit -> Set.t -> Pretty.doc
+    val d_set :
+      string ->
+      (unit -> Set.elt -> Pretty.doc) -> unit -> Set.t -> Pretty.doc
+  end \ No newline at end of file diff --git a/cil/doc/api/type_Pretty.html b/cil/doc/api/type_Pretty.html new file mode 100644 index 0000000..fc70f65 --- /dev/null +++ b/cil/doc/api/type_Pretty.html @@ -0,0 +1,111 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Pretty + + +sig
+  type doc
+  val nil : Pretty.doc
+  val ( ++ ) : Pretty.doc -> Pretty.doc -> Pretty.doc
+  val concat : Pretty.doc -> Pretty.doc -> Pretty.doc
+  val text : string -> Pretty.doc
+  val num : int -> Pretty.doc
+  val real : float -> Pretty.doc
+  val chr : char -> Pretty.doc
+  val line : Pretty.doc
+  val leftflush : Pretty.doc
+  val break : Pretty.doc
+  val align : Pretty.doc
+  val unalign : Pretty.doc
+  val mark : Pretty.doc
+  val unmark : Pretty.doc
+  val indent : int -> Pretty.doc -> Pretty.doc
+  val markup : Pretty.doc -> Pretty.doc
+  val seq :
+    sep:Pretty.doc ->
+    doit:('a -> Pretty.doc) -> elements:'a list -> Pretty.doc
+  val docList :
+    ?sep:Pretty.doc -> ('a -> Pretty.doc) -> unit -> 'a list -> Pretty.doc
+  val d_list :
+    string -> (unit -> 'a -> Pretty.doc) -> unit -> 'a list -> Pretty.doc
+  val docArray :
+    ?sep:Pretty.doc ->
+    (int -> 'a -> Pretty.doc) -> unit -> 'a array -> Pretty.doc
+  val docOpt : ('a -> Pretty.doc) -> unit -> 'a option -> Pretty.doc
+  val d_int32 : int32 -> Pretty.doc
+  val f_int32 : unit -> int32 -> Pretty.doc
+  val d_int64 : int64 -> Pretty.doc
+  val f_int64 : unit -> int64 -> Pretty.doc
+  module MakeMapPrinter :
+    functor
+      (Map : sig
+               type key
+               type 'a t
+               val fold :
+                 (Pretty.MakeMapPrinter.key -> 'a -> 'b -> 'b) ->
+                 'a Pretty.MakeMapPrinter.t -> 'b -> 'b
+             end) ->
+      sig
+        val docMap :
+          ?sep:Pretty.doc ->
+          (Map.key -> 'a -> Pretty.doc) -> unit -> 'a Map.t -> Pretty.doc
+        val d_map :
+          ?dmaplet:(Pretty.doc -> Pretty.doc -> Pretty.doc) ->
+          string ->
+          (unit -> Map.key -> Pretty.doc) ->
+          (unit -> 'a -> Pretty.doc) -> unit -> 'a Map.t -> Pretty.doc
+      end
+  module MakeSetPrinter :
+    functor
+      (Set : sig
+               type elt
+               type t
+               val fold :
+                 (Pretty.MakeSetPrinter.elt -> 'a -> 'a) ->
+                 Pretty.MakeSetPrinter.t -> 'a -> 'a
+             end) ->
+      sig
+        val docSet :
+          ?sep:Pretty.doc ->
+          (Set.elt -> Pretty.doc) -> unit -> Set.t -> Pretty.doc
+        val d_set :
+          string ->
+          (unit -> Set.elt -> Pretty.doc) -> unit -> Set.t -> Pretty.doc
+      end
+  val insert : unit -> Pretty.doc -> Pretty.doc
+  val dprintf : ('a, unit, Pretty.doc, Pretty.doc) format4 -> 'a
+  val gprintf :
+    (Pretty.doc -> 'a) -> ('b, unit, Pretty.doc, 'a) format4 -> 'b
+  val fprint : Pervasives.out_channel -> width:int -> Pretty.doc -> unit
+  val sprint : width:int -> Pretty.doc -> string
+  val fprintf :
+    Pervasives.out_channel -> ('a, unit, Pretty.doc) Pervasives.format -> 'a
+  val printf : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+  val eprintf : ('a, unit, Pretty.doc) Pervasives.format -> 'a
+  val withPrintDepth : int -> (unit -> unit) -> unit
+  val printDepth : int Pervasives.ref
+  val printIndent : bool Pervasives.ref
+  val fastMode : bool Pervasives.ref
+  val flushOften : bool Pervasives.ref
+  val countNewLines : int Pervasives.ref
+  val auto_printer : string -> 'a
+end \ No newline at end of file diff --git a/cil/doc/api/type_Stats.html b/cil/doc/api/type_Stats.html new file mode 100644 index 0000000..77cd218 --- /dev/null +++ b/cil/doc/api/type_Stats.html @@ -0,0 +1,36 @@ + + + + + + + + + + + + + + + + + + + + + +CIL API Documentation (version 1.3.5) : Stats + + +sig
+  val reset : bool -> unit
+  exception NoPerfCount
+  val has_performance_counters : unit -> bool
+  val sample_pentium_perfcount_20 : unit -> int
+  val sample_pentium_perfcount_10 : unit -> int
+  val time : string -> ('a -> 'b) -> 'a -> 'b
+  val repeattime : float -> string -> ('a -> 'b) -> 'a -> 'b
+  val print : Pervasives.out_channel -> string -> unit
+  val lastTime : float Pervasives.ref
+  val timethis : ('a -> 'b) -> 'a -> 'b
+end \ No newline at end of file diff --git a/cil/doc/changes.html b/cil/doc/changes.html new file mode 100644 index 0000000..17ffdf7 --- /dev/null +++ b/cil/doc/changes.html @@ -0,0 +1,486 @@ + + + + + + + + + + + + + +Changes + + + +Previous +Up +
+ +

20  Changes

+
  • +May 20, 2006: Released version 1.3.5 +
  • May 19, 2006: Makefile.cil.in/Makefile.cil have + been renamed Makefile.in/Makefile. And maincil.ml has + been renamed main.ml. +
  • May 18, 2006: Added a new module Cfg to compute the + control-flow graph. Unlike the older Cil.computeCFGInfo, + the new version does not modify the code. +
  • May 18, 2006: Added several new analyses: reaching + definitions, available expressions, liveness analysis, and dead code + elimination. See Section 8. +
  • May 2, 2006: Added a flag --noInsertImplicitCasts. + When this flag is used, CIL code will only include casts inserted by + the programmer. Implicit coercions are not changed to explicit casts. +
  • April 16, 2006: Minor improvements to the --stats + flag (Section 7.2). We now use Pentium performance + counters by default, if your processor supports them. +
  • April 10, 2006: Extended machdep.c to support + microcontroller compilers where the struct alignment of integer + types does not match the size of the type. Thanks to Nathan + Cooprider for the patch. +
  • April 6, 2006: Fix for global initializers of unions when + the union field being initialized is not the first one, and for + missing initializers of unions when the first field is not the + largest field. +
  • April 6, 2006: Fix for bitfields in the SFI module. +
  • April 6, 2006: Various fixes for gcc attributes. + packed, section, and always_inline attributes are now + parsed correctly. Also fixed printing of attributes on enum types. +
  • March 30, 2006: Fix for rmtemps.ml, which deletes + unused inline functions. When in gcc mode CIL now leaves all + inline functions in place, since gcc treats these as externally + visible. +
  • March 15, 2006: Fix for typeof(e) when e has type + void. +
  • March 3, 2006: Assume inline assembly instructions can + fall through for the purposes of adding return statements. Thanks to + Nathan Cooprider for the patch. +
  • February 27, 2006: Fix for extern inline functions when + the output of CIL is fed back into CIL. +
  • January 30, 2006: Fix parsing of switch without braces. +
  • January 30, 2006: Allow `$' to appear in identifiers. +
  • January 13, 2006: Added support for gcc's alias attribute + on functions. See Section 16.2, item 8. +
  • December 9, 2005: Christoph Spiel fixed the Golf and + Olf modules so that Golf can be used with the points-to analysis. + He also added performance fixes and cleaned up the documentation. +
  • December 1, 2005: Major rewrite of the ext/callgraph module. +
  • December 1, 2005: Preserve enumeration constants in CIL. Default +is the old behavior to replace them with integers. +
  • November 30, 2005: Added support for many GCC __builtin + functions. +
  • November 30, 2005: Added the EXTRAFEATURES configure + option, making it easier to add Features to the build process. +
  • November 23, 2005: In MSVC mode do not remove any locals whose name + appears as a substring in an inline assembly. +
  • November 23, 2005: Do not add a return to functions that have the + noreturn attribute. +
  • November 22, 2005: Released version 1.3.4 +
  • November 21, 2005: Performance and correctness fixes for + the Points-to Analysis module. Thanks to Christoph Spiel for the + patches. +
  • October 5, 2005: CIL now builds on SPARC/Solaris. Thanks + to Nick Petroni and Remco van Engelen for the patches. +
  • September 26, 2005: CIL no longer uses the `-I-' flag + by default when preprocessing with gcc. +
  • August 24, 2005: Added a command-line option + “--forceRLArgEval” that forces function arguments to be evaluated + right-to-left. This is the default behavior in unoptimized gcc and + MSVC, but the order of evaluation is undefined when using + optimizations, unless you apply this CIL transformation. This flag + does not affect the order of evaluation of e.g. binary operators, + which remains undefined. Thanks to Nathan Cooprider for the patch. +
  • August 9, 2005: Fixed merging when there are more than 20 + input files. +
  • August 3, 2005: When merging, it is now an error to + declare the same global variable twice with different initializers. +
  • July 27, 2005: Fixed bug in transparent unions. +
  • July 27, 2005: Fixed bug in collectInitializer. Thanks to + Benjamin Monate for the patch. +
  • July 26, 2005: Better support for extended inline assembly + in gcc. +
  • July 26, 2005: Added many more gcc __builtin* functions + to CIL. Most are treated as Call instructions, but a few are + translated into expressions so that they can be used in global + initializers. For example, “__builtin_offsetof(t, field)” is + rewritten as “&((t*)0)->field”, the traditional way of calculating + an offset. +
  • July 18, 2005: Fixed bug in the constant folding of shifts + when the second argument was negative or too large. +
  • July 18, 2005: Fixed bug where casts were not always + inserted in function calls. +
  • June 10, 2005: Fixed bug in the code that makes implicit + returns explicit. We weren't handling switch blocks correctly. +
  • June 1, 2005: Released version 1.3.3 +
  • May 31, 2005: Fixed handling of noreturn attribute for function + pointers. +
  • May 30, 2005: Fixed bugs in the handling of constructors in gcc. +
  • May 30, 2005: Fixed bugs in the generation of global variable IDs. +
  • May 27, 2005: Reimplemented the translation of function calls so + that we can intercept some builtins. This is important for the uses of + __builtin_constant_p in constants. +
  • May 27, 2005: Export the plainCilPrinter, for debugging. +
  • May 27, 2005: Fixed bug with printing of const attribute for + arrays. +
  • May 27, 2005: Fixed bug in generation of type signatures. Now they + should not contain expressions anymore, so you can use structural equality. + This used to lead to Out_of_Memory exceptions. +
  • May 27, 2005: Fixed bug in type comparisons using + TBuiltin_va_list. +
  • May 27, 2005: Improved the constant folding in array lengths and + case expressions. +
  • May 27, 2005: Added the __builtin_frame_address to the set + of gcc builtins. +
  • May 27, 2005: Added the CIL project to SourceForge. +
  • April 23, 2005: The cattr field was not visited. +
  • March 6, 2005: Debian packaging support +
  • February 16, 2005: Merger fixes. +
  • February 11, 2005: Fixed a bug in --dopartial. Thanks to +Nathan Cooprider for this fix. +
  • January 31, 2005: Make sure the input file is closed even if a + parsing error is encountered. +
  • January 11, 2005: Released version 1.3.2 +
  • January 11, 2005: Fixed printing of integer constants whose + integer kind is shorter than an int. +
  • January 11, 2005: Added checks for negative size arrays and arrays + too big. +
  • January 10, 2005: Added support for GCC attribute “volatile” for + tunctions (as a synonim for noreturn). +
  • January 10, 2005: Improved the comparison of array sizes when + comparing array types. +
  • January 10, 2005: Fixed handling of shell metacharacters in the + cilly command lione. +
  • January 10, 2005: Fixed dropping of cast in initialization of + local variable with the result of a function call. +
  • January 10, 2005: Fixed some structural comparisons that were + broken in the Ocaml 3.08. +
  • January 10, 2005: Fixed the unrollType function to not forget + attributes. +
  • January 10, 2005: Better keeping track of locations of function + prototypes and definitions. +
  • January 10, 2005: Fixed bug with the expansion of enumeration + constants in attributes. +
  • October 18, 2004: Fixed a bug in cabsvisit.ml. CIl would wrap a + BLOCK around a single atom unnecessarily. +
  • August 7, 2004: Released version 1.3.1 +
  • August 4, 2004: Fixed a bug in splitting of structs using + --dosimplify +
  • July 29, 2004: Minor changes to the type typeSig (type signatures) + to ensure that they do not contain types, so that you can do structural + comparison without danger of nontermination. +
  • July 28, 2004: Ocaml version 3.08 is required. Numerous small + changes while porting to Ocaml 3.08. +
  • July 7, 2004: Released version 1.2.6 +
  • July 2, 2004: Character constants such as 'c' should + have type int, not char. Added a utility function + Cil.charConstToInt that sign-extends chars greater than 128, if needed. +
  • July 2, 2004: Fixed a bug that was casting values to int + before applying the logical negation operator !. This caused + problems for floats, and for integer types bigger than int. +
  • June 13, 2004: Added the field sallstmts to a function + description, to hold all statements in the function. +
  • June 13, 2004: Added new extensions for data flow analyses, and + for computing dominators. +
  • June 10, 2004: Force initialization of CIL at the start of +Cabs2cil. +
  • June 9, 2004: Added support for GCC __attribute_used__ +
  • April 7, 2004: Released version 1.2.5 +
  • April 7, 2004: Allow now to run ./configure CC=cl and set the MSVC +compiler to be the default. The MSVC driver will now select the default name +of the .exe file like the CL compiler. +
  • April 7, 2004: Fixed a bug in the driver. The temporary files are +deleted by the Perl script before the CL compiler gets to them? +
  • April 7, 2004: Added the - form of arguments to the MSVC driver. +
  • April 7, 2004: Added a few more GCC-specific string escapes, (, [, +{, %, E. +
  • April 7, 2004: Fixed bug with continuation lines in MSVC. +
  • April 6, 2004: Fixed embarassing bug in the parser: the precedence + of casts and unary operators was switched. +
  • April 5, 2004: Fixed a bug involving statements mixed between +declarations containing initializers. Now we make sure that the initializers +are run in the proper order with respect to the statements. +
  • April 5, 2004: Fixed a bug in the merger. The merger was keeping +separate alpha renaming talbes (namespaces) for variables and types. This +means that it might end up with a type and a variable named the same way, if +they come from different files, which breaks an important CIL invariant. +
  • March 11, 2004 : Fixed a bug in the Cil.copyFunction function. The +new local variables were not getting fresh IDs. +
  • March 5, 2004: Fixed a bug in the handling of static function + prototypes in a block scope. They used to be renamed. Now we just consider + them global. +
  • February 20, 2004: Released version 1.2.4 +
  • February 15, 2004: Changed the parser to allow extra semicolons + after field declarations. +
  • February 14, 2004: Changed the Errormsg functions: error, unimp, +bug to not raise an exception. Instead they just set Errormsg.hadErrors. +
  • February 13, 2004: Change the parsing of attributes to recognize + enumeration constants. +
  • February 10, 2004: In some versions of gcc the identifier + _{thread is an identifier and in others it is a keyword. Added code + during configuration to detect which is the case. +
  • January 7, 2004: Released version 1.2.3 +
  • January 7, 2004: Changed the alpha renamer to be less +conservative. It will remember all versions of a name that were seen and will +only create a new name if we have not seen one. +
  • December 30, 2003 : Extended the cilly command to understand + better linker command options -lfoo. +
  • December 5, 2003: Added markup commands to the pretty-printer +module. Also, changed the “@<” left-flush command into “@''. +
  • December 4, 2003: Wide string literals are now handled +directly by Cil (rather than being exploded into arrays). This is +apparently handy for Microsoft Device Driver APIs that use intrinsic +functions that require literal constant wide-string arguments. +
  • December 3, 2003: Added support for structured exception handling + extensions for the Microsoft compilers. +
  • December 1, 2003: Fixed a Makefile bug in the generation of the +Cil library (e.g., cil.cma) that was causing it to be unusable. Thanks +to KEvin Millikin for pointing out this bug. +
  • November 26, 2003: Added support for linkage specifications + (extern “C”). +
  • November 26, 2003: Added the ocamlutil directory to contain some +utilities shared with other projects. +
  • November 25, 2003: Released version 1.2.2 +
  • November 24, 2003: Fixed a bug that allowed a static local to + conflict with a global with the same name that is declared later in the + file. +
  • November 24, 2003: Removed the --keep option of the cilly + driver and replaced it with --save-temps. +
  • November 24, 2003: Added printing of what CIL features are being + run. +
  • November 24, 2003: Fixed a bug that resulted in attributes being + dropped for integer types. +
  • November 11, 2003: Fixed a bug in the visitor for enumeration + definitions. +
  • October 24, 2003: Fixed a problem in the configuration script. It + was not recognizing the Ocaml version number for beta versions. +
  • October 15, 2003: Fixed a problem in version 1.2.1 that was + preventing compilation on OCaml 3.04. +
  • September 17, 2003: Released version 1.2.1. +
  • September 7, 2003: Redesigned the interface for choosing + #line directive printing styles. Cil.printLn and + Cil.printLnComment have been merged into Cil.lineDirectiveStyle. +
  • August 8, 2003: Do not silently pad out functions calls with +arguments to match the prototype. +
  • August 1, 2003: A variety of fixes suggested by Steve Chamberlain: +initializers for externs, prohibit float literals in enum, initializers for +unsized arrays were not working always, an overflow problem in Ocaml, changed +the processing of attributes before struct specifiers
    +
    +
  • July 14, 2003: Add basic support for GCC's "__thread" storage +qualifier. If given, it will appear as a "thread" attribute at the top of the +type of the declared object. Treatment is very similar to "__declspec(...)" +in MSVC
    +
    +
  • July 8, 2003: Fixed some of the __alignof computations. Fixed + bug in the designated initializers for arrays (Array.get error). +
  • July 8, 2003: Fixed infinite loop bug (Stack Overflow) in the + visitor for __alignof. +
  • July 8, 2003: Fixed bug in the conversion to CIL. A function or + array argument of + the GCC __typeof() was being converted to pointer type. Instead, it should + be left alone, just like for sizeof. +
  • July 7, 2003: New Escape module provides utility functions + for escaping characters and strings in accordance with C lexical + rules.
    +
    +
  • July 2, 2003: Relax CIL's rules for when two enumeration types are +considered compatible. Previously CIL considered two enums to be compatible if +they were the same enum. Now we follow the C99 standard.
    +
    +
  • June 28, 2003: In the Formatparse module, Eric Haugh found and + fixed a bug in the handling of lvalues of the form “lv->field.more”.
    +
    +
  • June 28, 2003: Extended the handling of gcc command lines +arguments in the Perl scripts.
    +
    +
  • June 23, 2003: In Rmtmps module, simplified the API for + customizing the root set. Clients may supply a predicate that + returns true for each root global. Modifying various + “referenced” fields directly is no longer supported.
    +
    +
  • June 17, 2003: Reimplement internal utility routine + Cil.escape_char. Faster and better.
    +
    +
  • June 14, 2003: Implemented support for __attribute__s +appearing between "struct" and the struct tag name (also for unions and +enums), since gcc supports this as documented in section 4.30 of the gcc +(2.95.3) manual
    +
    +
  • May 30, 2003: Released the regression tests. +
  • May 28, 2003: Released version 1.1.2 +
  • May 26, 2003: Add the simplify module that compiles CIL +expressions into simpler expressions, similar to those that appear in a +3-address intermediate language. +
  • May 26, 2003: Various fixes and improvements to the pointer +analysis modules. +
  • May 26, 2003: Added optional consistency checking for +transformations. +
  • May 25, 2003: Added configuration support for big endian machines. +Now Cil.little_endian can be used to test whether the machine is +little endian or not. +
  • May 22, 2003: Fixed a bug in the handling of inline functions. The +CIL merger used to turn these functions into “static”, which is incorrect. +
  • May 22, 2003: Expanded the CIL consistency checker to verify +undesired sharing relationships between data structures. +
  • May 22, 2003: Fixed bug in the oneret CIL module: it was +mishandling certain labeled return statements. +
  • May 5, 2003: Released version 1.0.11 +
  • May 5, 2003: OS X (powerpc/darwin) support for CIL. Special +thanks to Jeff Foster, Andy Begel and Tim Leek. +
  • April 30, 2003: Better description of how to use CIL for your +analysis. +
  • April 28, 2003: Fixed a bug with --dooneRet and +--doheapify. Thanks, Manos Renieris. +
  • April 16, 2003: Reworked management of + temporary/intermediate output files in Perl driver scripts. Default + behavior is now to remove all such files. To keep intermediate + files, use one of the following existing flags: +
    • + --keepmerged for the single-file merge of all sources +
    • --keep=<dir> for various other CIL and + CCured output files +
    • --save-temps for various gcc intermediate files; MSVC + has no equivalent option +
    + As part of this change, some intermediate files have changed their + names slightly so that new suffixes are always preceded by a + period. For example, CCured output that used to appear in + “foocured.c” now appears in “foo.cured.c”. +
  • April 7, 2003: Changed the representation of the Cil.GVar +global constructor. Now it is possible to update the initializer without +reconstructing the global (which in turn it would require reconstructing the +list of globals that make up a program). We did this because it is often +tempting to use Cil.visitCilFileSameGlobals and the Cil.GVar +was the only global that could not be updated in place. +
  • April 6, 2003: Reimplemented parts of the cilly.pl script to make +it more robust in the presence of complex compiler arguments. +
  • March 10, 2003: Released version 1.0.9 +
  • March 10, 2003: Unified and documented a large number of CIL +Library Modules: oneret, simplemem, makecfg, heapify, stackguard, partial. +Also documented the main client interface for the pointer analysis. +
  • February 18, 2003: Fixed a bug in logwrites that was causing it +to produce invalid C code on writes to bitfields. Thanks, David Park. +
  • February 15, 2003: Released version 1.0.8 +
  • February 15, 2003: PDF versions of the manual and API are +available for those who would like to print them out. +
  • February 14, 2003: CIL now comes bundled with alias analyses. +
  • February 11, 2003: Added support for adding/removing options from + ./configure. +
  • February 3, 2003: Released version 1.0.7 +
  • February 1, 2003: Some bug fixes in the handling of variable +argument functions in new versions of gcc And glibc. +
  • January 29, 2003: Added the logical AND and OR operators. +Exapanded the translation to CIL to handle more complicated initializers +(including those that contain logical operators). +
  • January 28, 2003: Released version 1.0.6 +
  • January 28, 2003: Added support for the new handling of +variable-argument functions in new versions of glibc. +
  • January 19, 2003: Added support for declarations in interpreted + constructors. Relaxed the semantics of the patterns for variables. +
  • January 17, 2003: Added built-in prototypes for the gcc built-in + functions. Changed the pGlobal method in the printers to print the + carriage return as well. +
  • January 9, 2003: Reworked lexer and parser's strategy for + tracking source file names and line numbers to more closely match + typical native compiler behavior. The visible CIL interface is + unchanged. +
  • January 9, 2003: Changed the interface to the alpha convertor. Now +you can pass a list where it will record undo information that you can use to +revert the changes that it makes to the scope tables. +
  • January 6, 2003: Released version 1.0.5 +
  • January 4, 2003: Changed the interface for the Formatcil module. + Now the placeholders in the pattern have names. Also expanded the + documentation of the Formatcil module. + Now the placeholders in the pattern have names. +
  • January 3, 2003: Extended the rmtmps module to also remove + unused labels that are generated in the conversion to CIL. This reduces the + number of warnings that you get from cgcc afterwards. +
  • December 17, 2002: Fixed a few bugs in CIL related to the + representation of string literals. The standard says that a string literal + is an array. In CIL, a string literal has type pointer to character. This is + Ok, except as an argument of sizeof. To support this exception, we have + added to CIL the expression constructor SizeOfStr. This allowed us to fix + bugs with computing sizeof("foo bar") and sizeof((char*)"foo bar") + (the former is 8 and the latter is 4).
    +
    +
  • December 8, 2002: Fixed a few bugs in the lexer and parser + relating to hex and octal escapes in string literals. Also fixed + the dependencies between the lexer and parser. +
  • December 5, 2002: Fixed visitor bugs that were causing + some attributes not to be visited and some queued instructions to be + dropped. +
  • December 3, 2002: Added a transformation to catch stack + overflows. Fixed the heapify transformation. +
  • October 14, 2002: CIL is now available under the BSD license +(see the License section or the file LICENSE). Released version 1.0.4 +
  • October 9, 2002: More FreeBSD configuration changes, support +for the GCC-ims __signed and __volatile. Thanks to Axel +Simon for pointing out these problems. Released version 1.0.3 +
  • October 8, 2002: FreeBSD configuration and porting fixes. +Thanks to Axel Simon for pointing out these problems. +
  • September 10, 2002: Fixed bug in conversion to CIL. Now we drop +all “const” qualifiers from the types of locals, even from the fields of +local structures or elements of arrays. +
  • September 7, 2002: Extended visitor interface to distinguish visitng + offsets inside lvalues from offsets inside initializer lists. +
  • September 7, 2002: Released version 1.0.1 +
  • September 6, 2002: Extended the patcher with the ateof flag. +
  • September 4, 2002: Fixed bug in the elaboration to CIL. In some +cases constant folding of || and && was computed wrong. +
  • September 3, 2002: Fixed the merger documentation. +
  • August 29, 2002: Released version 1.0.0. +
  • August 29, 2002: Started numbering versions with a major nubmer, +minor and revisions. Released version 1.0.0. +
  • August 25, 2002: Fixed the implementation of the unique +identifiers for global variables and composites. Now those identifiers are +globally unique. +
  • August 24, 2002: Added to the machine-dependent configuration the +sizeofvoid. It is 1 on gcc and 0 on MSVC. Extended the implementation of +Cil.bitsSizeOf to handle this (it was previously returning an error when +trying to compute the size of void). +
  • August 24, 2002: Changed the representation of structure and +unions to distinguish between undefined structures and those that are defined +to be empty (allowed on gcc). The sizeof operator is undefined for the former +and returns 0 for the latter. +
  • August 22, 2002: Apply a patch from Richard H. Y. to support +FreeBSD installations. Thanks, Richard! +
  • August 12, 2002: Fixed a bug in the translation of wide-character +strings. Now this translation matches that of the underlying compiler. Changed +the implementation of the compiler dependencies. +
  • May 25, 2002: Added interpreted constructors and destructors. +
  • May 17, 2002: Changed the representation of functions to move the +“inline” information to the varinfo. This way we can print the “inline” +even in declarations which is what gcc does. +
  • May 15, 2002: Changed the visitor for initializers to make two +tail-recursive passes (the second is a List.rev and only done if one of +the initializers change). This prevents Stack_Overflow for large +initializers. Also improved the processing of initializers when converting to +CIL. +
  • May 15, 2002: Changed the front-end to allow the use of MSVC +mode even on machines that do not have MSVC. The machine-dependent parameters +for GCC will be used in that case. +
  • May 11, 2002: Changed the representation of formals in function +types. Now the function type is purely functional. +
  • May 4, 2002: Added the function +Cil.visitCilFileSameGlobals and changed Cil.visitCilFile to be +tail recursive. This prevents stack overflow on huge files. +
  • February 28, 2002: Changed the significance of the +CompoundInit in Cil.init to allow for missing initializers at the +end of an array initializer. Added the API function +Cil.foldLeftCompoundAll. +
+
+Previous +Up + + diff --git a/cil/doc/cil.css b/cil/doc/cil.css new file mode 100644 index 0000000..7466cf4 --- /dev/null +++ b/cil/doc/cil.css @@ -0,0 +1,10 @@ + +.toc{list-style:none;} +.title{margin:auto;text-align:center} +.center{text-align:center;margin-left:auto;margin-right:auto;} +.flushleft{text-align:left;margin-left:0ex;margin-right:auto;} +.flushright{text-align:right;margin-left:auto;margin-right:0ex;} +DIV TABLE{margin-left:inherit;margin-right:inherit;} +PRE{text-align:left;margin-left:0ex;margin-right:auto;} +BLOCKQUOTE{margin-left:4ex;margin-right:4ex;text-align:left;} +.part{margin:auto;text-align:center} diff --git a/cil/doc/cil.html b/cil/doc/cil.html new file mode 100644 index 0000000..4d912d3 --- /dev/null +++ b/cil/doc/cil.html @@ -0,0 +1,3532 @@ + + + + + + + + + + + + + + + + + + + + + + + + + +

+ + +

1  Introduction

+ +New: CIL now has a Source Forge page: + http://sourceforge.net/projects/cil.
+
+CIL (C Intermediate Language) is a high-level representation +along with a set of tools that permit easy analysis and source-to-source +transformation of C programs.
+
+CIL is both lower-level than abstract-syntax trees, by clarifying ambiguous +constructs and removing redundant ones, and also higher-level than typical +intermediate languages designed for compilation, by maintaining types and a +close relationship with the source program. The main advantage of CIL is that +it compiles all valid C programs into a few core constructs with a very clean +semantics. Also CIL has a syntax-directed type system that makes it easy to +analyze and manipulate C programs. Furthermore, the CIL front-end is able to +process not only ANSI-C programs but also those using Microsoft C or GNU C +extensions. If you do not use CIL and want instead to use just a C parser and +analyze programs expressed as abstract-syntax trees then your analysis will +have to handle a lot of ugly corners of the language (let alone the fact that +parsing C itself is not a trivial task). See Section 16 for some +examples of such extreme programs that CIL simplifies for you.
+
+In essence, CIL is a highly-structured, “clean” subset of C. CIL features a +reduced number of syntactic and conceptual forms. For example, all looping +constructs are reduced to a single form, all function bodies are given +explicit return statements, syntactic sugar like "->" is +eliminated and function arguments with array types become pointers. (For an +extensive list of how CIL simplifies C programs, see Section 4.) +This reduces the number of cases that must be considered when manipulating a C +program. CIL also separates type declarations from code and flattens scopes +within function bodies. This structures the program in a manner more amenable +to rapid analysis and transformation. CIL computes the types of all program +expressions, and makes all type promotions and casts explicit. CIL supports +all GCC and MSVC extensions except for nested functions and complex numbers. +Finally, CIL organizes C's imperative features into expressions, instructions +and statements based on the presence and absence of side-effects and +control-flow. Every statement can be annotated with successor and predecessor +information. Thus CIL provides an integrated program representation that can +be used with routines that require an AST (e.g. type-based analyses and +pretty-printers), as well as with routines that require a CFG (e.g., dataflow +analyses). CIL also supports even lower-level representations (e.g., +three-address code), see Section 8.
+
+CIL comes accompanied by a number of Perl scripts that perform generally +useful operations on code: +
  • +A driver which behaves as either the gcc or +Microsoft VC compiler and can invoke the preprocessor followed by the CIL +application. The advantage of this script is that you can easily use CIL and +the analyses written for CIL with existing make files. +
  • A whole-program merger that you can use as a +replacement for your compiler and it learns all the files you compile when you +make a project and merges all of the preprocessed source files into a single +one. This makes it easy to do whole-program analysis. +
  • A patcher makes it easy to create modified +copies of the system include files. The CIL driver can then be told to use +these patched copies instead of the standard ones. +
+CIL has been tested very extensively. It is able to process the SPECINT95 +benchmarks, the Linux kernel, GIMP and other open-source projects. All of +these programs are compiled to the simple CIL and then passed to gcc and +they still run! We consider the compilation of Linux a major feat especially +since Linux contains many of the ugly GCC extensions (see Section 16.2). +This adds to about 1,000,000 lines of code that we tested it on. It is also +able to process the few Microsoft NT device drivers that we have had access +to. CIL was tested against GCC's c-torture testsuite and (except for the tests +involving complex numbers and inner functions, which CIL does not currently +implement) CIL passes most of the tests. Specifically CIL fails 23 tests out +of the 904 c-torture tests that it should pass. GCC itself fails 19 tests. A +total of 1400 regression test cases are run automatically on each change to +the CIL sources.
+
+CIL is relatively independent on the underlying machine and compiler. When +you build it CIL will configure itself according to the underlying compiler. +However, CIL has only been tested on Intel x86 using the gcc compiler on Linux +and cygwin and using the MS Visual C compiler. (See below for specific +versions of these compilers that we have used CIL for.)
+
+The largest application we have used CIL for is +CCured, a compiler that compiles C code into +type-safe code by analyzing your pointer usage and inserting runtime checks in +the places that cannot be guaranteed statically to be type safe.
+
+You can also use CIL to “compile” code that uses GCC extensions (e.g. the +Linux kernel) into standard C code.
+
+CIL also comes accompanies by a growing library of extensions (see +Section 8). You can use these for your projects or as examples of +using CIL.
+
+PDF versions of this manual and the +CIL API are available. However, we recommend the +HTML versions because the postprocessed code examples are easier to +view.
+
+If you use CIL in your project, we would appreciate letting us know. If you +want to cite CIL in your research writings, please refer to the paper “CIL: +Intermediate Language and Tools for Analysis and Transformation of C +Programs” by George C. Necula, Scott McPeak, S.P. Rahul and Westley Weimer, +in “Proceedings of Conference on Compilier Construction”, 2002.
+
+ + +

2  Installation

+ +You will need OCaml release 3.08 or higher to build CIL. CIL has been tested +on Linux and on Windows (where it can behave at either Microsoft Visual C or +gcc).
+
+If you want to use CIL on Windows then you must get a complete installation +of cygwin and the source-code OCaml distribution and compile it yourself +using the cygwin tools (as opposed to getting the Win32 native-code version of +OCaml). If you have not done this before then take a look +here. (Don't need to worry about cvs and +ssh unless you will need to use the master CVS repository for CIL.) +
  1. +Download the CIL distribution (latest version is +distrib/cil-1.3.5.tar.gz). See the Section 20 for recent changes to the CIL distribution. +
  2. Unzip and untar the source distribution. This will create a directory + called cil whose structure is explained below.
    +tar xvfz cil-1.3.5.tar.gz +
  3. Enter the cil directory and run the configure script and then + GNU make to build the distribution. If you are on Windows, at least the + configure step must be run from within bash.
    +    cd cil
    +    ./configure
    +    make
    +    make quicktest
    +
  4. You should now find cilly.asm.exe in a +subdirectory of obj. The name of the subdirectory is either x86_WIN32 +if you are using cygwin on Windows or x86_LINUX if you are using +Linux (although you should be using instead the Perl wrapper bin/cilly). +Note that we do not have an install make target and you should use Cil +from the development directory. +
  5. If you decide to use CIL, please +send us a note. This will help recharge +our batteries after more than a year of development. And of course, do send us +your bug reports as well.
+The configure script tries to find appropriate defaults for your system. +You can control its actions by passing the following arguments: +
  • +CC=foo Specifies the path for the gcc executable. By default +whichever version is in the PATH is used. If CC specifies the Microsoft +cl compiler, then that compiler will be set as the default one. Otherwise, +the gcc compiler will be the default. +
+CIL requires an underlying C compiler and preprocessor. CIL depends on the +underlying compiler and machine for the sizes and alignment of types.The +installation procedure for CIL queries the underlying compiler for +architecture and compiler dependent configuration parameters, such as the size +of a pointer or the particular alignment rules for structure fields. (This +means, of course, that you should re-run ./configure when you move CIL to +another machine.)
+
+We have tested CIL on the following compilers: +
  • +On Windows, cl compiler version 12.00.8168 (MSVC 6), + 13.00.9466 (MSVC .Net), and 13.10.3077 (MSVC .Net 2003). Run cl + with no arguments to get the compiler version. +
  • On Windows, using cygwin and gcc version 2.95.3, 3.0, + 3.2, 3.3, and 3.4. +
  • On Linux, using gcc version 2.95.3, 3.0, 3.2, 3.3, and 4.0. +
+Others have successfully used CIL with Mac OS X (on both PowerPC and +x86), Solaris, and *BSD. If you make any changes to the build +system in order to run CIL on your platform, please send us a patch.
+
+ + +

3  Distribution Contents

+ +The file distrib/cil-1.3.5.tar.gz +contains the complete source CIL distribution, +consisting of the following files:
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
FilenameDescription
Makefile.inconfigure source for the + Makefile that builds CIL
configureThe configure script
configure.inThe autoconf source for configure
config.guess, config.sub, install-shstuff required by + configure
 
doc/HTML documentation of the CIL API
obj/Directory that will contain the compiled + CIL modules and executables
bin/cilly.inThe configure source for a Perl script + that can be invoked with the + same arguments as either gcc or + Microsoft Visual C and will convert the + program to CIL, perform some simple + transformations, emit it and compile it as + usual.
lib/CompilerStub.pmA Perl class that can be used to write code + that impersonates a compiler. cilly + uses it.
lib/Merger.pmA subclass of CompilerStub.pm that can + be used to merge source files into a single + source file.cilly + uses it.
bin/patcher.inA Perl script that applies specified patches + to standard include files.
 
src/check.ml,mliChecks the well-formedness of a CIL file
src/cil.ml,mliDefinition of CIL abstract syntax and + utilities for manipulating it
src/clist.ml,mliUtilities for efficiently managing lists + that need to be concatenated often
src/errormsg.ml,mliUtilities for error reporting
src/ext/heapify.mlA CIL transformation that moves array local + variables from the stack to the heap
src/ext/logcalls.ml,mliA CIL transformation that logs every + function call
src/ext/sfi.mlA CIL transformation that can log every + memory read and write
src/frontc/clexer.mllThe lexer
src/frontc/cparser.mlyThe parser
src/frontc/cabs.mlThe abstract syntax
src/frontc/cprint.mlThe pretty printer for CABS
src/frontc/cabs2cil.mlThe elaborator to CIL
src/main.mlThe cilly application
src/pretty.ml,mliUtilities for pretty printing
src/rmtmps.ml,mliA CIL tranformation that removes unused + types, variables and inlined functions
src/stats.ml,mliUtilities for maintaining timing statistics
src/testcil.mlA random test of CIL (against the resident + C compiler)
src/trace.ml,mliUtilities useful for printing debugging + information
 
ocamlutil/Miscellaneous libraries that are not + specific to CIL.
ocamlutil/Makefile.ocamlA file that is included by Makefile
ocamlutil/Makefile.ocaml.buildA file that is included by Makefile
ocamlutil/perfcount.cC code that links with src/stats.ml + and reads Intel performance + counters.
 
obj/@ARCHOS@/feature_config.mlFile generated by the Makefile + describing which extra “features” + to compile. See Section 5
obj/@ARCHOS@/machdep.mlFile generated by the Makefile containing + information about your architecture, + such as the size of a pointer
src/machdep.cC program that generates + machdep.ml files

+ + +

4  Compiling C to CIL

+ +In this section we try to describe a few of the many transformations that are +applied to a C program to convert it to CIL. The module that implements this +conversion is about 5000 lines of OCaml code. In contrast a simple program +transformation that instruments all functions to keep a shadow stack of the +true return address (thus preventing stack smashing) is only 70 lines of code. +This example shows that the analysis is so much simpler because it has to +handle only a few simple C constructs and also because it can leverage on CIL +infrastructure such as visitors and pretty-printers.
+
+In no particular order these are a few of the most significant ways in which +C programs are compiled into CIL: +
  1. +CIL will eliminate all declarations for unused entities. This means that +just because your hello world program includes stdio.h it does not mean +that your analysis has to handle all the ugly stuff from stdio.h.
    +
    +
  2. Type specifiers are interpreted and normalized: +
    
+int long signed x;
+signed long extern x;
+long static int long y;
+
+// Some code that uses these declaration, so that CIL does not remove them
+int main() { return x + y; }
+
    +See the CIL output for this +code fragment
    +
    +
  3. Anonymous structure and union declarations are given a name. +
    
+ struct { int x; } s;
+
    +See the CIL output for this +code fragment
    +
    +
  4. Nested structure tag definitions are pulled apart. This means that all +structure tag definitions can be found by a simple scan of the globals. +
    
+struct foo {
+   struct bar {
+      union baz { 
+          int x1; 
+          double x2;
+      } u1;
+      int y;
+   } s1;
+   int z;
+} f;
+
    +See the CIL output for this +code fragment
    +
    +
  5. All structure, union, enumeration definitions and the type definitions +from inners scopes are moved to global scope (with appropriate renaming). This +facilitates moving around of the references to these entities. +
    
+int main() {
+  struct foo { 
+        int x; } foo; 
+  {
+     struct foo { 
+        double d;
+     };
+     return foo.x;
+  }      
+}
+
    +See the CIL output for this +code fragment
    +
    +
  6. Prototypes are added for those functions that are called before being +defined. Furthermore, if a prototype exists but does not specify the type of +parameters that is fixed. But CIL will not be able to add prototypes for those +functions that are neither declared nor defined (but are used!). +
    
+  int f();  // Prototype without arguments
+  int f(double x) {
+      return g(x);
+  }
+  int g(double x) {
+     return x;
+  } 
+
    +See the CIL output for this +code fragment
    +
    +
  7. Array lengths are computed based on the initializers or by constant +folding. +
    
+  int a1[] = {1,2,3};
+  int a2[sizeof(int) >= 4 ? 8 : 16];
+
    +See the CIL output for this +code fragment
    +
    +
  8. Enumeration tags are computed using constant folding: +
    
+int main() {
+  enum { 
+     FIVE = 5, 
+     SIX, SEVEN, 
+     FOUR = FIVE - 1, 
+     EIGHT = sizeof(double)
+  } x = FIVE;
+ return x;
+}
+
+
    +See the CIL output for this +code fragment
    +
    +
  9. Initializers are normalized to include specific initialization for the +missing elements: +
    
+  int a1[5] = {1,2,3};
+  struct foo { int x, y; } s1 = { 4 };
+
    +See the CIL output for this +code fragment
    +
    +
  10. Initializer designators are interpreted and eliminated. Subobjects are +properly marked with braces. CIL implements +the whole ISO C99 specification for initializer (neither GCC nor MSVC do) and +a few GCC extensions. +
    
+  struct foo { 
+     int x, y; 
+     int a[5];
+     struct inner {
+        int z;
+     } inner;
+  } s = { 0, .inner.z = 3, .a[1 ... 2] = 5, 4, y : 8 };
+
    +See the CIL output for this +code fragment
    +
    +
  11. String initializers for arrays of characters are processed +
    
+char foo[] = "foo plus bar";
+
    +See the CIL output for this +code fragment
    +
    +
  12. String constants are concatenated +
    
+char *foo = "foo " " plus " " bar ";
+
    +See the CIL output for this +code fragment
    +
    +
  13. Initializers for local variables are turned into assignments. This is in +order to separate completely the declarative part of a function body from the +statements. This has the unfortunate effect that we have to drop the const +qualifier from local variables ! +
    
+  int x = 5; 
+  struct foo { int f1, f2; } a [] = {1, 2, 3, 4, 5 };
+
    +See the CIL output for this +code fragment
    +
    +
  14. Local variables in inner scopes are pulled to function scope (with +appropriate renaming). Local scopes thus disappear. This makes it easy to find +and operate on all local variables in a function. +
    
+  int x = 5; 
+  int main() {
+    int x = 6;
+    { 
+      int x = 7;
+      return x;
+    }
+    return x;
+  } 
+
    +See the CIL output for this +code fragment
    +
    +
  15. Global declarations in local scopes are moved to global scope: +
    
+  int x = 5; 
+  int main() {
+    int x = 6;
+    { 
+      static int x = 7;
+      return x;
+    }
+    return x;
+  } 
+
    +See the CIL output for this +code fragment
    +
    +
  16. Return statements are added for functions that are missing them. If the +return type is not a base type then a return without a value is added. +The guaranteed presence of return statements makes it easy to implement a +transformation that inserts some code to be executed immediately before +returning from a function. +
    
+  int foo() {
+    int x = 5;
+  } 
+
    +See the CIL output for this +code fragment
    +
    +
  17. One of the most significant transformations is that expressions that +contain side-effects are separated into statements. +
    
+   int x, f(int);
+   return (x ++ + f(x));
+
    +See the CIL output for this +code fragment
    +
    +Internally, the x ++ statement is turned into an assignment which the +pretty-printer prints like the original. CIL has only three forms of basic +statements: assignments, function calls and inline assembly.
    +
    +
  18. Shortcut evaluation of boolean expressions and the ?: operator are +compiled into explicit conditionals: +
    
+  int x;
+  int y = x ? 2 : 4;
+  int z = x || y;
+  // Here we duplicate the return statement
+  if(x && y) { return 0; } else { return 1; }
+  // To avoid excessive duplication, CIL uses goto's for 
+  // statement that have more than 5 instructions
+  if(x && y || z) { x ++; y ++; z ++; x ++; y ++; return z; }
+
    +See the CIL output for this +code fragment
    +
    +
  19. GCC's conditional expression with missing operands are also compiled +into conditionals: +
    
+  int f();;
+  return f() ? : 4;
+
    +See the CIL output for this +code fragment
    +
    +
  20. All forms of loops (while, for and do) are compiled +internally as a single while(1) looping construct with explicit break +statement for termination. For simple while loops the pretty printer is +able to print back the original: +
    
+   int x, y;
+   for(int i = 0; i<5; i++) {
+      if(i == 5) continue;
+      if(i == 4) break;
+      i += 2;
+   } 
+   while(x < 5) {
+     if(x == 3) continue;
+     x ++;
+   }
+
    +See the CIL output for this +code fragment
    +
    +
  21. GCC's block expressions are compiled away. (That's right there is an +infinite loop in this code.) +
    
+   int x = 5, y = x;
+   int z = ({ x++; L: y -= x; y;});
+   return ({ goto L; 0; });
+
    +See the CIL output for this +code fragment
    +
    +
  22. CIL contains support for both MSVC and GCC inline assembly (both in one +internal construct)
    +
    +
  23. CIL compiles away the GCC extension that allows many kinds of constructs +to be used as lvalues: +
    
+   int x, y, z;
+   return &(x ? y : z) - & (x ++, x);
+
    +See the CIL output for this +code fragment
    +
    +
  24. All types are computed and explicit casts are inserted for all +promotions and conversions that a compiler must insert:
    +
    +
  25. CIL will turn old-style function definition (without prototype) into +new-style definitions. This will make the compiler less forgiving when +checking function calls, and will catch for example cases when a function is +called with too few arguments. This happens in old-style code for the purpose +of implementing variable argument functions.
    +
    +
  26. Since CIL sees the source after preprocessing the code after CIL does +not contain the comments and the preprocessing directives.
    +
    +
  27. CIL will remove from the source file those type declarations, local +variables and inline functions that are not used in the file. This means that +your analysis does not have to see all the ugly stuff that comes from the +header files: +
    
+#include <stdio.h>
+
+typedef int unused_type;
+
+static char unused_static (void) { return 0; }
+
+int main() {
+  int unused_local;
+  printf("Hello world\n"); // Only printf will be kept from stdio.h     
+}
+
    +See the CIL output for this +code fragment
+ + +

5  How to Use CIL

+ +
+
+There are two predominant ways to use CIL to write a program analysis or +transformation. The first is to phrase your analysis as a module that is +called by our existing driver. The second is to use CIL as a stand-alone +library. We highly recommend that you use cilly, our driver.
+
+ + +

5.1  Using cilly, the CIL driver

+ +The most common way to use CIL is to write an Ocaml module containing your +analysis and transformation, which you then link into our boilerplate +driver application called cilly. cilly is a Perl script that +processes and mimics GCC and MSVC command-line arguments and then +calls cilly.byte.exe or cilly.asm.exe (CIL's Ocaml executable).
+
+An example of such module is logwrites.ml, a transformation that is +distributed with CIL and whose purpose is to instrument code to print the +addresses of memory locations being written. (We plan to release a +C-language interface to CIL so that you can write your analyses in C +instead of Ocaml.) See Section 8 for a survey of other example +modules.
+
+Assuming that you have written /home/necula/logwrites.ml, +here is how you use it: +
  1. Modify logwrites.ml so that it includes a CIL “feature + descriptor” like this: +
    +let feature : featureDescr = 
+  { fd_name = "logwrites";              
+    fd_enabled = ref false;
+    fd_description = "generation of code to log memory writes";
+    fd_extraopt = [];
+    fd_doit = 
+    (function (f: file) -> 
+      let lwVisitor = new logWriteVisitor in
+      visitCilFileSameGlobals lwVisitor f)
+  } 
+
    The fd_name field names the feature and its associated + command-line arguments. The fd_enabled field is a bool ref. + “fd_doit” will be invoked if !fd_enabled is true after + argument parsing, so initialize the ref cell to true if you want + this feature to be enabled by default.
    +
    +When the user passes the --dologwrites + command-line option to cilly, the variable associated with the + fd_enabled flag is set and the fd_doit function is called + on the Cil.file that represents the merger (see Section 13) of + all C files listed as arguments.
    +
    +
  2. Invoke configure with the arguments +
    +./configure EXTRASRCDIRS=/home/necula EXTRAFEATURES=logwrites
+
    + This step works if each feature is packaged into its own ML file, and the +name of the entry point in the file is feature.
    +
    +An alternative way to specify the new features is to change the build files +yourself, as explained below. You'll need to use this method if a single +feature is split across multiple files. +
    1. + Put logwrites.ml in the src or src/ext directory. This + will make sure that make can find it. If you want to put it in some + other directory, modify Makefile.in and add to SOURCEDIRS your + directory. Alternately, you can create a symlink from src or + src/ext to your file.
      +
      +
    2. Modify the Makefile.in and add your module to the + CILLY_MODULES or + CILLY_LIBRARY_MODULES variables. The order of the modules matters. Add + your modules somewhere after cil and before main.
      +
      +
    3. If you have any helper files for your module, add those to + the makefile in the same way. e.g.: +
      +CILLY_MODULES = $(CILLY_LIBRARY_MODULES) \
+                myutilities1 myutilities2 logwrites \
+                main
+
      + Again, order is important: myutilities2.ml will be able to refer + to Myutilities1 but not Logwrites. If you have any ocamllex or ocamlyacc + files, add them to both CILLY_MODULES and either MLLS or + MLYS.
      +
      +
    4. Modify main.ml so that your new feature descriptor appears in + the global list of CIL features. +
      +let features : C.featureDescr list = 
+  [ Logcalls.feature;
+    Oneret.feature;    
+    Heapify.feature1;  
+    Heapify.feature2;
+    makeCFGFeature; 
+    Partial.feature;
+    Simplemem.feature;
+    Logwrites.feature;  (* add this line to include the logwrites feature! *)
+  ] 
+  @ Feature_config.features 
+
      + Features are processed in the order they appear on this list. Put + your feature last on the list if you plan to run any of CIL's + built-in features (such as makeCFGfeature) before your own.

    +Standard code in cilly takes care of adding command-line arguments, + printing the description, and calling your function automatically. + Note: do not worry about introducing new bugs into CIL by adding a single + line to the feature list.
    +
    +
  3. Now you can invoke the cilly application on a preprocessed file, or + instead use the cilly driver which provides a convenient compiler-like + interface to cilly. See Section 7 for details using cilly. + Remember to enable your analysis by passing the right argument (e.g., + --dologwrites).
+ + +

5.2  Using CIL as a library

+ +CIL can also be built as a library that is called from your stand-alone +application. Add cil/src, cil/src/frontc, cil/obj/x86_LINUX +(or cil/obj/x86_WIN32) to your Ocaml project -I include paths. +Building CIL will also build the library cil/obj/*/cil.cma (or +cil/obj/*/cil.cmxa). You can then link your application against that +library.
+
+You can call the Frontc.parse: string -> unit -> Cil.file function with +the name of a file containing the output of the C preprocessor. +The Mergecil.merge: Cil.file list -> string -> Cil.file function merges +multiple files. You can then invoke your analysis function on the resulting +Cil.file data structure. You might want to call +Rmtmps.removeUnusedTemps first to clean up the prototypes and variables +that are not used. Then you can call the function Cil.dumpFile: +cilPrinter -> out_channel -> Cil.file -> unit to print the file to a +given output channel. A good cilPrinter to use is +defaultCilPrinter.
+
+Check out src/main.ml and bin/cilly for other good ideas +about high-level file processing. Again, we highly recommend that you just +our cilly driver so that you can avoid spending time re-inventing the +wheel to provide drop-in support for standard makefiles.
+
+Here is a concrete example of compiling and linking your project against +CIL. Imagine that your program analysis or transformation is contained in +the single file main.ml. +
+$ ocamlopt -c -I $(CIL)/obj/x86_LINUX/ main.ml
+$ ocamlopt -ccopt -L$(CIL)/obj/x86_LINUX/ -o main unix.cmxa str.cmxa \ 
+        $(CIL)/obj/x86_LINUX/cil.cmxa main.cmx
+
+The first line compiles your analysis, the second line links it against CIL +(as a library) and the Ocaml Unix library. For more information about +compiling and linking Ocaml programs, see the Ocaml home page +at http://caml.inria.fr/ocaml/.
+
+In the next section we give an overview of the API that you can use +to write your analysis and transformation.
+
+ + +

6  CIL API Documentation

+ +The CIL API is documented in the file src/cil.mli. We also have an +online documentation extracted from cil.mli. We +index below the main types that are used to represent C programs in CIL: + + + +

6.1  Using the visitor

+ +One of the most useful tools exported by the CIL API is an implementation of +the visitor pattern for CIL programs. The visiting engine scans depth-first +the structure of a CIL program and at each node is queries a user-provided +visitor structure whether it should do one of the following operations: +
  • +Ignore this node and all its descendants +
  • Descend into all of the children and when done rebuild the node if any +of the children have changed. +
  • Replace the subtree rooted at the node with another tree. +
  • Replace the subtree with another tree, then descend into the children +and rebuild the node if necessary and then invoke a user-specified function. +
  • In addition to all of the above actions then visitor can specify that +some instructions should be queued to be inserted before the current +instruction or statement being visited. +
+By writing visitors you can customize the program traversal and +transformation. One major limitation of the visiting engine is that it does +not propagate information from one node to another. Each visitor must use its +own private data to achieve this effect if necessary.
+
+Each visitor is an object that is an instance of a class of type Cil.cilVisitor.. +The most convenient way to obtain such classes is to specialize the +Cil.nopCilVisitor.class (which just traverses the tree doing +nothing). Any given specialization typically overrides only a few of the +methods. Take a look for example at the visitor defined in the module +logwrites.ml. Another, more elaborate example of a visitor is the +[copyFunctionVisitor] defined in cil.ml.
+
+Once you have defined a visitor you can invoke it with one of the functions: + +Some transformations may want to use visitors to insert additional +instructions before statements and instructions. To do so, pass a list of +instructions to the Cil.queueInstr method of the specialized +object. The instructions will automatically be inserted before that +instruction in the transformed code. The Cil.unqueueInstr method +should not normally be called by the user.
+
+ + +

6.2  Interpreted Constructors and Deconstructors

+ +Interpreted constructors and deconstructors are a facility for constructing +and deconstructing CIL constructs using a pattern with holes that can be +filled with a variety of kinds of elements. The pattern is a string that uses +the C syntax to represent C language elements. For example, the following +code: +

+Formatcil.cType "void * const (*)(int x)"
+
+is an alternative way to construct the internal representation of the type of pointer to function +with an integer argument and a void * const as result: +

+TPtr(TFun(TVoid [Attr("const", [])],
+          [ ("x", TInt(IInt, []), []) ], false, []), [])
+
+The advantage of the interpreted constructors is that you can use familiar C +syntax to construct CIL abstract-syntax trees.
+
+You can construct this way types, lvalues, expressions, instructions and +statements. The pattern string can also contain a number of placeholders that +are replaced during construction with CIL items passed as additional argument +to the construction function. For example, the %e:id placeholder means +that the argument labeled “id” (expected to be of form Fe exp) will +supply the expression to replace the placeholder. For example, the following +code constructs an increment instruction at location loc: +

+Formatcil.cInstr "%v:x = %v:x + %e:something"
+        loc
+        [ ("something", Fe some_exp);
+          ("x", Fv some_varinfo) ]
+
+An alternative way to construct the same CIL instruction is: +

+Set((Var some_varinfo, NoOffset),
+    BinOp(PlusA, Lval (Var some_varinfo, NoOffset),
+          some_exp, intType), 
+    loc)
+
+See Cil.formatArg for a definition of the placeholders that are +understood.
+
+A dual feature is the interpreted deconstructors. This can be used to test +whether a CIL construct has a certain form: +

+Formatcil.dType "void * const (*)(int x)" t
+
+will test whether the actual argument t is indeed a function pointer of +the required type. If it is then the result is Some [] otherwise it is +None. Furthermore, for the purpose of the interpreted deconstructors +placeholders in patterns match anything of the right type. For example, +

+Formatcil.dType "void * (*)(%F:t)" t
+
+will match any function pointer type, independent of the type and number of +the formals. If the match succeeds the result is Some [ FF forms ] where +forms is a list of names and types of the formals. Note that each member +in the resulting list corresponds positionally to a placeholder in the +pattern.
+
+The interpreted constructors and deconstructors do not support the complete C +syntax, but only a substantial fragment chosen to simplify the parsing. The +following is the syntax that is supported: +
+Expressions:
+  E ::= %e:ID | %d:ID | %g:ID | n | L | ( E ) | Unop E | E Binop E 
+        | sizeof E | sizeof ( T ) | alignof E  | alignof ( T ) 
+        | & L | ( T ) E 
+
+Unary operators:
+  Unop ::= + | - | ~ | %u:ID
+
+Binary operators:
+  Binop ::= + | - | * | / | << | >> | & | ``|'' | ^ 
+          | == | != | < | > | <= | >= | %b:ID
+
+Lvalues:
+  L ::= %l:ID | %v:ID Offset | * E | (* E) Offset | E -> ident Offset 
+
+Offsets:
+  Offset ::= empty | %o:ID | . ident Offset | [ E ] Offset
+
+Types:
+  T ::= Type_spec Attrs Decl
+
+Type specifiers:
+  Type_spec ::= void | char | unsigned char | short | unsigned short
+            | int | unsigned int | long | unsigned long | %k:ID | float 
+            | double | struct %c:ID | union %c:ID 
+
+
+Declarators:
+  Decl ::= * Attrs Decl | Direct_decl
+
+
+Direct declarators:
+  Direct_decl ::= empty | ident | ( Attrs Decl ) 
+                 | Direct_decl [ Exp_opt ]
+                 | ( Attrs Decl )( Parameters )
+
+Optional expressions
+  Exp_opt ::= empty | E | %eo:ID
+
+Formal parameters
+  Parameters ::= empty | ... | %va:ID | %f:ID | T | T , Parameters
+
+List of attributes
+  Attrs ::= empty | %A:ID | Attrib Attrs
+
+Attributes
+  Attrib ::= const | restrict | volatile | __attribute__ ( ( GAttr ) )
+
+GCC Attributes
+  GAttr ::= ident | ident ( AttrArg_List )
+
+Lists of GCC Attribute arguments:
+  AttrArg_List ::= AttrArg | %P:ID | AttrArg , AttrArg_List
+
+GCC Attribute arguments  
+  AttrArg ::= %p:ID | ident | ident ( AttrArg_List )
+
+Instructions
+  Instr ::= %i:ID ; | L = E ; | L Binop= E | Callres L ( Args )
+
+Actual arguments
+   Args ::= empty | %E:ID | E | E , Args
+
+Call destination
+   Callres ::= empty | L = | %lo:ID
+
+Statements
+  Stmt ::= %s:ID | if ( E ) then Stmt ; | if ( E ) then Stmt else Stmt ;
+       | return Exp_opt | break ; | continue ; | { Stmt_list } 
+       | while (E ) Stmt | Instr_list 
+
+Lists of statements
+   Stmt_list ::= empty | %S:ID | Stmt Stmt_list  
+                | Type_spec Attrs Decl ; Stmt_list
+                | Type_spec Attrs Decl = E ; Stmt_list
+                | Type_spec Attrs Decl = L (Args) ; Stmt_list
+
+List of instructions
+   Instr_list ::= Instr | %I:ID | Instr Instr_list
+
+Notes regarding the syntax: +
  • +In the grammar description above non-terminals are written with +uppercase initial
    +
    +
  • All of the patterns consist of the % character followed by one or +two letters, followed by “:” and an indentifier. For each such +pattern there is a corresponding constructor of the Cil.formatArg +type, whose name is the letter 'F' followed by the same one or two letters as +in the pattern. That constructor is used by the user code to pass a +Cil.formatArg actual argument to the interpreted constructor and by +the interpreted deconstructor to return what was matched for a pattern.
    +
    +
  • If the pattern name is uppercase, it designates a list of the elements +designated by the corresponding lowercase pattern. E.g. %E designated lists +of expressions (as in the actual arguments of a call).
    +
    +
  • The two-letter patterns whose second letter is “o” designate an +optional element. E.g. %eo designates an optional expression (as in the +length of an array).
    +
    +
  • Unlike in calls to printf, the pattern %g is used for strings.
    +
    +
  • The usual precedence and associativity rules as in C apply
    +
    +
  • The pattern string can contain newlines and comments, using both the +/* ... */ style as well as the // one.
    +
    +
  • When matching a “cast” pattern of the form ( T ) E, the +deconstructor will match even expressions that do not have the actual cast but +in that case the type is matched against the type of the expression. E.g. the +patters "(int)%e" will match any expression of type int whether it +has an explicit cast or not.
    +
    +
  • The %k pattern is used to construct and deconstruct an integer type of +any kind.
    +
    +
  • Notice that the syntax of types and declaration are the same (in order +to simplify the parser). This means that technically you can write a whole +declaration instead of a type in the cast. In this case the name that you +declare is ignored.
    +
    +
  • In lists of formal parameters and lists of attributes, an empty list in +the pattern matches any formal parameters or attributes.
    +
    +
  • When matching types, uses of named types are unrolled to expose a real +type before matching.
    +
    +
  • The order of the attributes is ignored during matching. The the pattern +for a list of attributes contains %A then the resulting formatArg will be +bound to all attributes in the list. For example, the pattern "const +%A" matches any list of attributes that contains const and binds the +corresponding placeholder to the entire list of attributes, including +const.
    +
    +
  • All instruction-patterns must be terminated by semicolon
    +
    +
  • The autoincrement and autodecrement instructions are not supported. Also +not supported are complex expressions, the && and || shortcut +operators, and a number of other more complex instructions or statements. In +general, the patterns support only constructs that can be represented directly +in CIL.
    +
    +
  • The pattern argument identifiers are not used during deconstruction. +Instead, the result contains a sequence of values in the same order as the +appearance of pattern arguments in the pattern.
    +
    +
  • You can mix statements with declarations. For each declaration a new + temporary will be constructed (using a function you provive). You can then + refer to that temporary by name in the rest of the pattern.
    +
    +
  • The %v: pattern specifier is optional. +
+The following function are defined in the Formatcil module for +constructing and deconstructing: + +Below is an example using interpreted constructors. This example generates +the CIL representation of code that scans an array backwards and initializes +every even-index element with an expression: +

+Formatcil.cStmts
+  loc
+  "int idx = sizeof(array) / sizeof(array[0]) - 1;
+   while(idx >= 0) {
+     // Some statements to be run for all the elements of the array
+     %S:init
+     if(! (idx & 1)) 
+       array[idx] = %e:init_even;
+     /* Do not forget to decrement the index variable */
+     idx = idx - 1;
+   }"
+  (fun n t -> makeTempVar myfunc ~name:n t)
+  [ ("array", Fv myarray); 
+    ("init", FS [stmt1; stmt2; stmt3]);
+    ("init_even", Fe init_expr_for_even_elements) ]
+
+To write the same CIL statement directly in CIL would take much more effort. +Note that the pattern is parsed only once and the result (a function that +takes the arguments and constructs the statement) is memoized.
+
+ + +

6.2.1  Performance considerations for interpreted constructors

+ +Parsing the patterns is done with a LALR parser and it takes some time. To +improve performance the constructors and deconstructors memoize the parsed +patterns and will only compile a pattern once. Also all construction and +deconstruction functions can be applied partially to the pattern string to +produce a function that can be later used directly to construct or +deconstruct. This function appears to be about two times slower than if the +construction is done using the CIL constructors (without memoization the +process would be one order of magnitude slower.) However, the convenience of +interpreted constructor might make them a viable choice in many situations +when performance is not paramount (e.g. prototyping).
+
+ + +

6.3  Printing and Debugging support

+ +The Modules Pretty and Errormsg contain respectively +utilities for pretty printing and reporting errors and provide a convenient +printf-like interface.
+
+Additionally, CIL defines for each major type a pretty-printing function that +you can use in conjunction with the Pretty interface. The +following are some of the pretty-printing functions: + +You can even customize the pretty-printer by creating instances of +Cil.cilPrinter.. Typically such an instance extends +Cil.defaultCilPrinter. Once you have a customized pretty-printer you +can use the following printing functions: + +CIL has certain internal consistency invariants. For example, all references +to a global variable must point to the same varinfo structure. This +ensures that one can rename the variable by changing the name in the +varinfo. These constraints are mentioned in the API documentation. There +is also a consistency checker in file src/check.ml. If you suspect that +your transformation is breaking these constraints then you can pass the +--check option to cilly and this will ensure that the consistency checker +is run after each transformation.
+
+ + +

6.4  Attributes

+ +In CIL you can attach attributes to types and to names (variables, functions +and fields). Attributes are represented using the type Cil.attribute. +An attribute consists of a name and a number of arguments (represented using +the type Cil.attrparam). Almost any expression can be used as an +attribute argument. Attributes are stored in lists sorted by the name of the +attribute. To maintain list ordering, use the functions +Cil.typeAttrs to retrieve the attributes of a type and the functions +Cil.addAttribute and Cil.addAttributes to add attributes. +Alternatively you can use Cil.typeAddAttributes to add an attribute to +a type (and return the new type).
+
+GCC already has extensive support for attributes, and CIL extends this +support to user-defined attributes. A GCC attribute has the syntax: +
+ gccattribute ::= __attribute__((attribute))    (Note the double parentheses)
+
+ Since GCC and MSVC both support various flavors of each attribute (with or +without leading or trailing _) we first strip ALL leading and trailing _ +from the attribute name (but not the identified in [ACons] parameters in +Cil.attrparam). When we print attributes, for GCC we add two leading +and two trailing _; for MSVC we add just two leading _.
+
+There is support in CIL so that you can control the printing of attributes +(see Cil.setCustomPrintAttribute and +Cil.setCustomPrintAttributeScope). This custom-printing support is now +used to print the "const" qualifier as "const" and not as +"__attribute__((const))".
+
+The attributes are specified in declarations. This is unfortunate since the C +syntax for declarations is already quite complicated and after writing the +parser and elaborator for declarations I am convinced that few C programmers +understand it completely. Anyway, this seems to be the easiest way to support +attributes.
+
+Name attributes must be specified at the very end of the declaration, just +before the = for the initializer or before the , the separates a +declaration in a group of declarations or just before the ; that +terminates the declaration. A name attribute for a function being defined can +be specified just before the brace that starts the function body.
+
+For example (in the following examples A1,...,An are type attributes +and N is a name attribute (each of these uses the __attribute__ syntax): +

+ int x N;
+ int x N, * y N = 0, z[] N;
+ extern void exit() N;
+ int fact(int x) N { ... }
+
+Type attributes can be specified along with the type using the following + rules: +
  1. + The type attributes for a base type (int, float, named type, reference + to struct or union or enum) must be specified immediately following the + type (actually it is Ok to mix attributes with the specification of the + type, in between unsigned and int for example).
    +
    +For example: +
    
+  int A1 x N;  /* A1 applies to the type int. An example is an attribute
+                   "even" restricting the type int to even values. */
+  struct foo A1 A2 x; // Both A1 and A2 apply to the struct foo type
+

    +
    +
  2. The type attributes for a pointer type must be specified immediately + after the * symbol. +
    
+ /* A pointer (A1) to an int (A2) */
+ int A2 * A1 x;
+ /* A pointer (A1) to a pointer (A2) to a float (A3) */
+ float A3 * A2 * A1 x;
+
    +Note: The attributes for base types and for pointer types are a strict + extension of the ANSI C type qualifiers (const, volatile and restrict). In + fact CIL treats these qualifiers as attributes.
    +
    +
  3. The attributes for a function type or for an array type can be + specified using parenthesized declarators.
    +
    +For example: +
    
+   /* A function (A1) from int (A2) to float (A3) */
+   float A3 (A1 f)(int A2);
+
+   /* A pointer (A1) to a function (A2) that returns an int (A3) */
+   int A3 (A2 * A1 pfun)(void);
+
+   /* An array (A1) of int (A2) */
+   int A2 (A1 x0)[]
+
+   /* Array (A1) of pointers (A2) to functions (A3) that take an int (A4) and 
+    * return a pointer (A5) to int (A6)  */
+   int A6 * A5 (A3 * A2 (A1 x1)[5])(int A4);
+
+
+   /* A function (A4) that takes a float (A5) and returns a pointer (A6) to an 
+    * int (A7) */
+   extern int A7 * A6 (A4 x2)(float A5 x);
+
+   /* A function (A1) that takes a int (A2) and that returns a pointer (A3) to 
+    * a function (A4) that takes a float (A5) and returns a pointer (A6) to an 
+    * int (A7) */
+   int A7 * A6 (A4 * A3 (A1 x3)(int A2 x))(float A5) {
+      return & x2;
+   }
+
+Note: ANSI C does not allow the specification of type qualifiers for function +and array types, although it allows for the parenthesized declarator. With +just a bit of thought (looking at the first few examples above) I hope that +the placement of attributes for function and array types will seem intuitive.
+
+This extension is not without problems however. If you want to refer just to +a type (in a cast for example) then you leave the name out. But this leads to +strange conflicts due to the parentheses that we introduce to scope the +attributes. Take for example the type of x0 from above. It should be written +as: +

+        int A2 (A1 )[]
+
+But this will lead most C parsers into deep confusion because the parentheses +around A1 will be confused for parentheses of a function designator. To push +this problem around (I don't know a solution) whenever we are about to print a +parenthesized declarator with no name but with attributes, we comment out the +attributes so you can see them (for whatever is worth) without confusing the +compiler. For example, here is how we would print the above type: +

+        int A2 /*(A1 )*/[]
+
+ + +
Handling of predefined GCC attributes
+ +GCC already supports attributes in a lot of places in declarations. The only +place where we support attributes and GCC does not is right before the { that +starts a function body.
+
+GCC classifies its attributes in attributes for functions, for variables and +for types, although the latter category is only usable in definition of struct +or union types and is not nearly as powerful as the CIL type attributes. We +have made an effort to reclassify GCC attributes as name and type attributes +(they only apply for function types). Here is what we came up with: +
  • + GCC name attributes:
    +
    +section, constructor, destructor, unused, weak, no_instrument_function, + noreturn, alias, no_check_memory_usage, dllinport, dllexport, exception, + model
    +
    +Note: the "noreturn" attribute would be more appropriately qualified as a + function type attribute. But we classify it as a name attribute to make + it easier to support a similarly named MSVC attribute.
    +
    +
  • GCC function type attributes:
    +
    +fconst (printed as "const"), format, regparm, stdcall, + cdecl, longcall
    +
    +I was not able to completely decipher the position in which these attributes + must go. So, the CIL elaborator knows these names and applies the following + rules: +
    • + All of the name attributes that appear in the specifier part (i.e. at + the beginning) of a declaration are associated with all declared names.
      +
      +
    • All of the name attributes that appear at the end of a declarator are + associated with the particular name being declared.
      +
      +
    • More complicated is the handling of the function type attributes, since + there can be more than one function in a single declaration (a function + returning a pointer to a function). Lacking any real understanding of how + GCC handles this, I attach the function type attribute to the "nearest" + function. This means that if a pointer to a function is "nearby" the + attribute will be correctly associated with the function. In truth I pray + that nobody uses declarations as that of x3 above. +
    +
+ + +
Handling of predefined MSVC attributes
+ +MSVC has two kinds of attributes, declaration modifiers to be printed before + the storage specifier using the notation "__declspec(...)" and a few + function type attributes, printed almost as our CIL function type + attributes.
+
+The following are the name attributes that are printed using + __declspec right before the storage designator of the declaration: + thread, naked, dllimport, dllexport, noreturn
+
+The following are the function type attributes supported by MSVC: + fastcall, cdecl, stdcall
+
+It is not worth going into the obscure details of where MSVC accepts these + type attributes. The parser thinks it knows these details and it pulls + these attributes from wherever they might be placed. The important thing + is that MSVC will accept if we print them according to the rules of the CIL + attributes !
+
+ + +

7  The CIL Driver

+ +We have packaged CIL as an application cilly that contains certain +example modules, such as logwrites.ml (a module +that instruments code to print the addresses of memory locations being +written). Normally, you write another module like that, add command-line +options and an invocation of your module in src/main.ml. Once you compile +CIL you will obtain the file obj/cilly.asm.exe.
+
+We wrote a driver for this executable that makes it easy to invoke your +analysis on existing C code with very little manual intervention. This driver +is bin/cilly and is quite powerful. Note that the cilly script +is configured during installation with the path where CIL resides. This means +that you can move it to any place you want.
+
+A simple use of the driver is: +
+bin/cilly --save-temps -D HAPPY_MOOD -I myincludes hello.c -o hello
+
+--save-temps tells CIL to save the resulting output files in the +current directory. Otherwise, they'll be put in /tmp and deleted +automatically. Not that this is the only CIL-specific flag in the +list – the other flags use gcc's syntax.
+
+This performs the following actions: +
  • +preprocessing using the -D and -I arguments with the resulting + file left in hello.i, +
  • the invocation of the cilly.asm application which parses hello.i + converts it to CIL and the pretty-prints it to hello.cil.c +
  • another round of preprocessing with the result placed in hello.cil.i +
  • the true compilation with the result in hello.cil.o +
  • a linking phase with the result in hello +
+Note that cilly behaves like the gcc compiler. This makes it +easy to use it with existing Makefiles: +
+make CC="bin/cilly" LD="bin/cilly"
+
+ cilly can also behave as the Microsoft Visual C compiler, if the first + argument is --mode=MSVC: +
+bin/cilly --mode=MSVC /D HAPPY_MOOD /I myincludes hello.c /Fe hello.exe
+
+ (This in turn will pass a --MSVC flag to the underlying cilly.asm + process which will make it understand the Microsoft Visual C extensions)
+
+cilly can also behave as the archiver ar, if it is passed an +argument --mode=AR. Note that only the cr mode is supported (create a +new archive and replace all files in there). Therefore the previous version of +the archive is lost.
+
+Furthermore, cilly allows you to pass some arguments on to the +underlying cilly.asm process. As a general rule all arguments that start +with -- and that cilly itself does not process, are passed on. For +example, +
+bin/cilly --dologwrites -D HAPPY_MOOD -I myincludes hello.c -o hello.exe
+
+ will produce a file hello.cil.c that prints all the memory addresses +written by the application.
+
+The most powerful feature of cilly is that it can collect all the +sources in your project, merge them into one file and then apply CIL. This +makes it a breeze to do whole-program analysis and transformation. All you +have to do is to pass the --merge flag to cilly: +
+make CC="bin/cilly --save-temps --dologwrites --merge"
+
+ You can even leave some files untouched: +
+make CC="bin/cilly --save-temps --dologwrites --merge --leavealone=foo --leavealone=bar"
+
+ This will merge all the files except those with the basename foo and +bar. Those files will be compiled as usual and then linked in at the very +end.
+
+The sequence of actions performed by cilly depends on whether merging +is turned on or not: +
  • +If merging is off +
    1. + For every file file.c to compile +
      1. + Preprocess the file with the given arguments to + produce file.i +
      2. Invoke cilly.asm to produce a file.cil.c +
      3. Preprocess to file.cil.i +
      4. Invoke the underlying compiler to produce file.cil.o +
      +
    2. Link the resulting objects +
    +
  • If merging is on +
    1. + For every file file.c to compile +
      1. + Preprocess the file with the given arguments to + produce file.i +
      2. Save the preprocessed source as file.o +
      +
    2. When linking executable hello.exe, look at every object + file that must be linked and see if it actually + contains preprocessed source. Pass all those files to a + special merging application (described in + Section 13) to produce hello.exe_comb.c +
    3. Invoke cilly.asm to produce a hello.exe_comb.cil.c +
    4. Preprocess to hello.exe_comb.cil.i +
    5. Invoke the underlying compiler to produce hello.exe_comb.cil.o +
    6. Invoke the actual linker to produce hello.exe +
    +
+Note that files that you specify with --leavealone are not merged and +never presented to CIL. They are compiled as usual and then are linked in at +the end.
+
+And a final feature of cilly is that it can substitute copies of the +system's include files: +
+make CC="bin/cilly --includedir=myinclude"
+
+ This will force the preprocessor to use the file myinclude/xxx/stdio.h +(if it exists) whenever it encounters #include <stdio.h>. The xxx is +a string that identifies the compiler version you are using. This modified +include files should be produced with the patcher script (see +Section 14).
+
+ + +

7.1  cilly Options

+ +Among the options for the cilly you can put anything that can normally +go in the command line of the compiler that cilly is impersonating. +cilly will do its best to pass those options along to the appropriate +subprocess. In addition, the following options are supported (a complete and +up-to-date list can always be obtained by running cilly --help): +
  • +--mode=mode This must be the first argument if present. It makes +cilly behave as a given compiled. The following modes are recognized: +
    • + GNUCC - the GNU C Compiler. This is the default. +
    • MSVC - the Microsoft Visual C compiler. Of course, you should + pass only MSVC valid options in this case. +
    • AR - the archiver ar. Only the mode cr is supported and + the original version of the archive is lost. +
    +
  • --help Prints a list of the options supported. +
  • --verbose Prints lots of messages about what is going on. +
  • --stages Less than --verbose but lets you see what cilly + is doing. +
  • --merge This tells cilly to first attempt to collect into one +source file all of the sources that make your application, and then to apply +cilly.asm on the resulting source. The sequence of actions in this case is +described above and the merger itself is described in Section 13.
    +
    +
  • --leavealone=xxx. Do not merge and do not present to CIL the files +whose basename is "xxx". These files are compiled as usual and linked in at +the end. +
  • --includedir=xxx. Override the include files with those in the given +directory. The given directory is the same name that was given an an argument +to the patcher (see Section 14). In particular this means that +that directory contains subdirectories named based on the current compiler +version. The patcher creates those directories. +
  • --usecabs. Do not CIL, but instead just parse the source and print +its AST out. This should looked like the preprocessed file. This is useful +when you suspect that the conversion to CIL phase changes the meaning of the +program. +
  • --save-temps=xxx. Temporary files are preserved in the xxx + directory. For example, the output of CIL will be put in a file + named *.cil.c. +
  • --save-temps. Temporay files are preserved in the current directory. +
+ + +

7.2  cilly.asm Options

+ + +All of the options that start with -- and are not understood by +cilly are passed on to cilly.asm. cilly also passes along to +cilly.asm flags such as --MSVC that both need to know +about. The following options are supported:
+
+       General Options: +
  • + --version output version information and exit +
  • --verbose Print lots of random stuff. This is passed on from cilly +
  • --warnall Show all warnings. +
  • --debug=xxx turns on debugging flag xxx +
  • --nodebug=xxx turns off debugging flag xxx +
  • --flush Flush the output streams often (aids debugging). +
  • --check Run a consistency check over the CIL after every operation. +
  • --nocheck turns off consistency checking of CIL. +
  • --noPrintLn Don't output #line directives in the output. +
  • --commPrintLn Print #line directives in the output, but + put them in comments. +
  • --log=xxx Set the name of the log file. By default stderr is used +
  • --MSVC Enable MSVC compatibility. Default is GNU. +
  • --ignore-merge-conflicts ignore merging conflicts. +
  • --extrafiles=filename: the name of a file that contains + a list of additional files to process, separated by whitespace. +
  • --stats Print statistics about the running time of the + parser, conversion to CIL, etc. Also prints memory-usage + statistics. You can time parts of your own code as well. Calling + (Stats.time “label” func arg) will evaluate (func arg) + and remember how long this takes. If you call Stats.time + repeatedly with the same label, CIL will report the aggregate + time.
    +
    +If available, CIL uses the x86 performance counters for these + stats. This is very precise, but results in “wall-clock time.” + To report only user-mode time, find the call to Stats.reset in + main.ml, and change it to Stats.reset false.
    +
    +Lowering Options +
  • --noLowerConstants do not lower constant expressions. +
  • --noInsertImplicitCasts do not insert implicit casts. +
  • --forceRLArgEval Forces right to left evaluation of function arguments. +
  • --disallowDuplication Prevent small chunks of code from being duplicated. +
  • --keepunused Do not remove the unused variables and types. +
  • --rmUnusedInlines Delete any unused inline functions. This is the default in MSVC mode.
    +
    +Output Options: +
  • --printCilAsIs Do not try to simplify the CIL when + printing. Without this flag, CIL will attempt to produce prettier + output by e.g. changing while(1) into more meaningful loops. +
  • --noWrap do not wrap long lines when printing +
  • --out=xxx the name of the output CIL file. cilly + sets this for you. +
  • --mergedout=xxx specify the name of the merged file +
  • --cabsonly=xxx CABS output file name +
    +
    + Selected features. See Section 8 for more information. +
  • --dologcalls. Insert code in the processed source to print the name of +functions as are called. Implemented in src/ext/logcalls.ml. +
  • --dologwrites. Insert code in the processed source to print the +address of all memory writes. Implemented in src/ext/logwrites.ml. +
  • --dooneRet. Make each function have at most one 'return'. +Implemented in src/ext/oneret.ml. +
  • --dostackGuard. Instrument function calls and returns to +maintain a separate stack for return addresses. Implemeted in +src/ext/heapify.ml. +
  • --domakeCFG. Make the program look more like a CFG. Implemented +in src/cil.ml. +
  • --dopartial. Do interprocedural partial evaluation and +constant folding. Implemented in src/ext/partial.ml. +
  • --dosimpleMem. Simplify all memory expressions. Implemented in +src/ext/simplemem.ml.
    +
    +For an up-to-date list of available options, run cilly.asm --help.
+ + +

8  Library of CIL Modules

+ +
+
+We are developing a suite of modules that use CIL for program analyses and +transformations that we have found useful. You can use these modules directly +on your code, or generally as inspiration for writing similar modules. A +particularly big and complex application written on top of CIL is CCured +(../ccured/index.html).
+
+ + +

8.1  Control-Flow Graphs

+ +The Cil.stmt datatype includes fields for intraprocedural +control-flow information: the predecessor and successor statements of +the current statement. This information is not computed by default. +If you want to use the control-flow graph, or any of the extensions in +this section that require it, you have to explicitly ask CIL to +compute the CFG.
+
+ + +

8.1.1  The CFG module (new in CIL 1.3.5)

+ +The best way to compute the CFG is with the CFG module. Just invoke +Cfg.computeFileCFG on your file. The Cfg API +describes the rest of actions you can take with this module, including +computing the CFG for one function at a time, or printing the CFG in +dot form.
+
+ + +

8.1.2  Simplified control flow

+ +CIL can reduce high-level C control-flow constructs like switch and +continue to lower-level gotos. This completely eliminates some +possible classes of statements from the program and may make the result +easier to analyze (e.g., it simplifies data-flow analysis).
+
+You can invoke this transformation on the command line with +--domakeCFG or programatically with Cil.prepareCFG. +After calling Cil.prepareCFG, you can use Cil.computeCFGInfo +to compute the CFG information and find the successor and predecessor +of each statement.
+
+For a concrete example, you can see how cilly --domakeCFG +transforms the following code (note the fall-through in case 1): +

+  int foo (int predicate) {
+    int x = 0;
+    switch (predicate) {
+      case 0: return 111;
+      case 1: x = x + 1;
+      case 2: return (x+3);
+      case 3: break;
+      default: return 222;
+    }
+    return 333;
+  }
+
+See the CIL output for this +code fragment
+
+ + +

8.2  Data flow analysis framework

+ +The Dataflow module (click for the ocamldoc) contains a +parameterized framework for forward and backward data flow +analyses. You provide the transfer functions and this module does the +analysis. You must compute control-flow information (Section 8.1) +before invoking the Dataflow module.
+
+ + +

8.3  Dominators

+ +The module Dominators contains the computation of immediate + dominators. It uses the Dataflow module.
+
+ + +

8.4  Points-to Analysis

+ +The module ptranal.ml contains two interprocedural points-to +analyses for CIL: Olf and Golf. Olf is the default. +(Switching from olf.ml to golf.ml requires a change in +Ptranal and a recompiling cilly.)
+
+The analyses have the following characteristics: +
  • +Not based on C types (inferred pointer relationships are sound + despite most kinds of C casts) +
  • One level of subtyping +
  • One level of context sensitivity (Golf only) +
  • Monomorphic type structures +
  • Field insensitive (fields of structs are conflated) +
  • Demand-driven (points-to queries are solved on demand) +
  • Handle function pointers +
+The analysis itself is factored into two components: Ptranal, +which walks over the CIL file and generates constraints, and Olf +or Golf, which solve the constraints. The analysis is invoked +with the function Ptranal.analyze_file: Cil.file -> + unit. This function builds the points-to graph for the CIL file +and stores it internally. There is currently no facility for clearing +internal state, so Ptranal.analyze_file should only be called +once.
+
+The constructed points-to graph supports several kinds of queries, +including alias queries (may two expressions be aliased?) and +points-to queries (to what set of locations may an expression point?).
+
+The main interface with the alias analysis is as follows: +
  • +Ptranal.may_alias: Cil.exp -> Cil.exp -> bool. If + true, the two expressions may have the same value. +
  • Ptranal.resolve_lval: Cil.lval -> (Cil.varinfo + list). Returns the list of variables to which the given + left-hand value may point. +
  • Ptranal.resolve_exp: Cil.exp -> (Cil.varinfo list). + Returns the list of variables to which the given expression may + point. +
  • Ptranal.resolve_funptr: Cil.exp -> (Cil.fundec + list). Returns the list of functions to which the given + expression may point. +
+The precision of the analysis can be customized by changing the values +of several flags: +
  • +Ptranal.no_sub: bool ref. + If true, subtyping is disabled. Associated commandline option: + --ptr_unify. +
  • Ptranal.analyze_mono: bool ref. + (Golf only) If true, context sensitivity is disabled and the + analysis is effectively monomorphic. Commandline option: + --ptr_mono. +
  • Ptranal.smart_aliases: bool ref. + (Golf only) If true, “smart” disambiguation of aliases is + enabled. Otherwise, aliases are computed by intersecting points-to + sets. This is an experimental feature. +
  • Ptranal.model_strings: bool ref. + Make the alias analysis model string constants by treating them as + pointers to chars. Commandline option: --ptr_model_strings +
  • Ptranal.conservative_undefineds: bool ref. + Make the most pessimistic assumptions about globals if an undefined + function is present. Such a function can write to every global + variable. Commandline option: --ptr_conservative +
+In practice, the best precision/efficiency tradeoff is achieved by +setting Ptranal.no_sub to false, Ptranal.analyze_mono to +true, and Ptranal.smart_aliases to false. These are the +default values of the flags.
+
+There are also a few flags that can be used to inspect or serialize +the results of the analysis. +
  • +Ptranal.debug_may_aliases. + Print the may-alias relationship of each pair of expressions in the + program. Commandline option: --ptr_may_aliases. +
  • Ptranal.print_constraints: bool ref. + If true, the analysis will print each constraint as it is + generated. +
  • Ptranal.print_types: bool ref. + If true, the analysis will print the inferred type of each + variable in the program.
    +
    +If Ptranal.analyze_mono and Ptranal.no_sub are both + true, this output is sufficient to reconstruct the points-to + graph. One nice feature is that there is a pretty printer for + recursive types, so the print routine does not loop. +
  • Ptranal.compute_results: bool ref. + If true, the analysis will print out the points-to set of each + variable in the program. This will essentially serialize the + points-to graph. +
+ + +

8.5  StackGuard

+ +The module heapify.ml contains a transformation similar to the one +described in “StackGuard: Automatic Adaptive Detection and Prevention of +Buffer-Overflow Attacks”, Proceedings of the 7th USENIX Security +Conference. In essence it modifies the program to maintain a separate +stack for return addresses. Even if a buffer overrun attack occurs the +actual correct return address will be taken from the special stack.
+
+Although it does work, this CIL module is provided mainly as an example of +how to perform a simple source-to-source program analysis and +transformation. As an optimization only functions that contain a dangerous +local array make use of the special return address stack.
+
+For a concrete example, you can see how cilly --dostackGuard +transforms the following dangerous code: +

+  int dangerous() {
+    char array[10];
+    scanf("%s",array); // possible buffer overrun!
+  }
+
+  int main () {
+    return dangerous();
+  }
+
+See the CIL output for this +code fragment
+
+ + +

8.6  Heapify

+ +The module heapify.ml also contains a transformation that moves all +dangerous local arrays to the heap. This also prevents a number of buffer +overruns.
+
+For a concrete example, you can see how cilly --doheapify +transforms the following dangerous code: +

+  int dangerous() {
+    char array[10];
+    scanf("%s",array); // possible buffer overrun!
+  }
+
+  int main () {
+    return dangerous();
+  }
+
+See the CIL output for this +code fragment
+
+ + +

8.7  One Return

+ +The module oneret.ml contains a transformation the ensures that all +function bodies have at most one return statement. This simplifies a number +of analyses by providing a canonical exit-point.
+
+For a concrete example, you can see how cilly --dooneRet +transforms the following code: +

+  int foo (int predicate) {
+    if (predicate <= 0) {
+      return 1;
+    } else {
+      if (predicate > 5)
+        return 2;
+      return 3;
+    }
+  }
+
+See the CIL output for this +code fragment
+
+ + +

8.8  Partial Evaluation and Constant Folding

+ +The partial.ml module provides a simple interprocedural partial +evaluation and constant folding data-flow analysis and transformation. This +transformation requires the --domakeCFG option.
+
+For a concrete example, you can see how cilly --domakeCFG --dopartial +transforms the following code (note the eliminated if branch and the +partial optimization of foo): +

+  int foo(int x, int y) {
+    int unknown;
+    if (unknown)
+      return y+2;     
+    return x+3;      
+  }
+
+  int main () {
+    int a,b,c;
+    a = foo(5,7) + foo(6,7);
+    b = 4;
+    c = b * b;      
+    if (b > c)     
+      return b-c;
+    else
+      return b+c; 
+  }
+
+See the CIL output for this +code fragment
+
+ + +

8.9  Reaching Definitions

+ +The reachingdefs.ml module uses the dataflow framework and CFG +information to calculate the definitions that reach each +statement. After computing the CFG (Section 8.1) and calling +computeRDs on a +function declaration, ReachingDef.stmtStartData will contain a +mapping from statement IDs to data about which definitions reach each +statement. In particular, it is a mapping from statement IDs to a +triple the first two members of which are used internally. The third +member is a mapping from variable IDs to Sets of integer options. If +the set contains Some(i), then the definition of that variable +with ID i reaches that statement. If the set contains None, +then there is a path to that statement on which there is no definition +of that variable. Also, if the variable ID is unmapped at a +statement, then no definition of that variable reaches that statement.
+
+To summarize, reachingdefs.ml has the following interface: +
  • +computeRDs – Computes reaching definitions. Requires that +CFG information has already been computed for each statement. +
  • ReachingDef.stmtStartData – contains reaching +definition data after computeRDs is called. +
  • ReachingDef.defIdStmtHash – Contains a mapping +from definition IDs to the ID of the statement in which +the definition occurs. +
  • getRDs – Takes a statement ID and returns +reaching definition data for that statement. +
  • instrRDs – Takes a list of instructions and the +definitions that reach the first instruction, and for +each instruction calculates the definitions that reach +either into or out of that instruction. +
  • rdVisitorClass – A subclass of nopCilVisitor that +can be extended such that the current reaching definition +data is available when expressions are visited through +the get_cur_iosh method of the class. +
+ + +

8.10  Available Expressions

+ +The availexps.ml module uses the dataflow framework and CFG +information to calculate something similar to a traditional available +expressions analysis. After computeAEs is called following a CFG +calculation (Section 8.1), AvailableExps.stmtStartData will +contain a mapping +from statement IDs to data about what expressions are available at +that statement. The data for each statement is a mapping for each +variable ID to the whole expression available at that point(in the +traditional sense) which the variable was last defined to be. So, +this differs from a traditional available expressions analysis in that +only whole expressions from a variable definition are considered rather +than all expressions.
+
+The interface is as follows: +
  • +computeAEs – Computes available expressions. Requires +that CFG information has already been comptued for each statement. +
  • AvailableExps.stmtStartData – Contains available +expressions data for each statement after computeAEs has been +called. +
  • getAEs – Takes a statement ID and returns +available expression data for that statement. +
  • instrAEs – Takes a list of instructions and +the availalbe expressions at the first instruction, and +for each instruction calculates the expressions available +on entering or exiting each instruction. +
  • aeVisitorClass – A subclass of nopCilVisitor that +can be extended such that the current available expressions +data is available when expressions are visited through the +get_cur_eh method of the class. +
+ + +

8.11  Liveness Analysis

+ +The liveness.ml module uses the dataflow framework and +CFG information to calculate which variables are live at +each program point. After computeLiveness is called +following a CFG calculation (Section 8.1), LiveFlow.stmtStartData will +contain a mapping for each statement ID to a set of varinfos +for varialbes live at that program point.
+
+The interface is as follows: +
  • +computeLiveness – Computes live variables. Requires +that CFG information has already been computed for each statement. +
  • LiveFlow.stmtStartData – Contains live variable data +for each statement after computeLiveness has been called. +
+Also included in this module is a command line interface that +will cause liveness data to be printed to standard out for +a particular function or label. +
  • +–doliveness – Instructs cilly to comptue liveness +information and to print on standard out the variables live +at the points specified by –live_func and live_label. +If both are ommitted, then nothing is printed. +
  • –live_func – The name of the function whose +liveness data is of interest. If –live_label is ommitted, +then data for each statement is printed. +
  • –live_label – The name of the label at which +the liveness data will be printed. +
+ + +

8.12  Dead Code Elimination

+ +The module deadcodeelim.ml uses the reaching definitions +analysis to eliminate assignment instructions whose results +are not used. The interface is as follows: +
  • +elim_dead_code – Performs dead code elimination +on a function. Requires that CFG information has already +been computed (Section 8.1). +
  • dce – Performs dead code elimination on an +entire file. Requires that CFG information has already +been computed. +
+ + +

8.13  Simple Memory Operations

+ +The simplemem.ml module allows CIL lvalues that contain memory +accesses to be even futher simplified via the introduction of +well-typed temporaries. After this transformation all lvalues involve +at most one memory reference.
+
+For a concrete example, you can see how cilly --dosimpleMem +transforms the following code: +

+  int main () {
+    int ***three;
+    int **two;
+    ***three = **two; 
+  } 
+
+See the CIL output for this +code fragment
+
+ + +

8.14  Simple Three-Address Code

+ +The simplify.ml module further reduces the complexity of program +expressions and gives you a form of three-address code. After this +transformation all expressions will adhere to the following grammar: +
+ basic::=
+    Const _ 
+    Addrof(Var v, NoOffset)
+    StartOf(Var v, NoOffset)
+    Lval(Var v, off), where v is a variable whose address is not taken
+                      and off contains only "basic"
+
+ exp::=
+    basic
+    Lval(Mem basic, NoOffset)
+    BinOp(bop, basic, basic)
+    UnOp(uop, basic)
+    CastE(t, basic)
+   
+ lval ::= 
+    Mem basic, NoOffset
+    Var v, off, where v is a variable whose address is not taken and off
+                contains only "basic"
+
In addition, all sizeof and alignof forms are turned into +constants. Accesses to arrays and variables whose address is taken are +turned into "Mem" accesses. All field and index computations are turned +into address arithmetic.
+
+For a concrete example, you can see how cilly --dosimplify +transforms the following code: +

+  int main() {
+    struct mystruct {
+      int a;
+      int b;
+    } m;
+    int local;
+    int arr[3];
+    int *ptr;
+
+    ptr = &local;
+    m.a = local + sizeof(m) + arr[2];
+    return m.a; 
+  } 
+
+See the CIL output for this +code fragment
+
+ + +

8.15  Converting C to C++

+ +The module canonicalize.ml performs several transformations to correct +differences between C and C++, so that the output is (hopefully) valid +C++ code. This may be incomplete — certain fixes which are necessary +for some programs are not yet implemented.
+
+Using the --doCanonicalize option with CIL will perform the +following changes to your program: +
  1. +Any variables that use C++ keywords as identifiers are renamed. +
  2. C allows global variables to have multiple declarations and + multiple (equivalent) definitions. This transformation removes + all but one declaration and all but one definition. +
  3. __inline is #defined to inline, and __restrict + is #defined to nothing. +
  4. C allows function pointers with no specified arguments to be used on + any argument list. To make C++ accept this code, we insert a cast + from the function pointer to a type that matches the arguments. Of + course, this does nothing to guarantee that the pointer actually has + that type. +
  5. Makes casts from int to enum types explicit. (CIL changes enum + constants to int constants, but doesn't use a cast.) +
+ + +

9  Controlling CIL

+ +In the process of converting a C file to CIL we drop the unused prototypes +and even inline function definitions. This results in much smaller files. If +you do not want this behavior then you must pass the --keepunused argument +to the CIL application.
+
+Alternatively you can put the following pragma in the code (instructing CIL +to specifically keep the declarations and definitions of the function +func1 and variable var2, the definition of type foo and of +structure bar): +

+#pragma cilnoremove("func1", "var2", "type foo", "struct bar")
+
+ + +

10  GCC Extensions

+ +The CIL parser handles most of the gcc +extensions +and compiles them to CIL. The following extensions are not handled (note that +we are able to compile a large number of programs, including the Linux kernel, +without encountering these): +
  1. +Nested function definitions. +
  2. Constructing function calls. +
  3. Naming an expression's type. +
  4. Complex numbers +
  5. Hex floats +
  6. Subscripts on non-lvalue arrays. +
  7. Forward function parameter declarations +
+The following extensions are handled, typically by compiling them away: +
  1. +Attributes for functions, variables and types. In fact, we have a clear +specification (see Section 6.4) of how attributes are interpreted. The +specification extends that of gcc. +
  2. Old-style function definitions and prototypes. These are translated to +new-style. +
  3. Locally-declared labels. As part of the translation to CIL, we generate +new labels as needed. +
  4. Labels as values and computed goto. This allows a program to take the +address of a label and to manipulate it as any value and also to perform a +computed goto. We compile this by assigning each label whose address is taken +a small integer that acts as its address. Every computed goto in the body +of the function is replaced with a switch statement. If you want to invoke +the label from another function, you are on your own (the gcc +documentation says the same.) +
  5. Generalized lvalues. You can write code like (a, b) += 5 and it gets +translated to CIL. +
  6. Conditionals with omitted operands. Things like x ? : y are +translated to CIL. +
  7. Double word integers. The type long long and the LL suffix on +constants is understood. This is currently interpreted as 64-bit integers. +
  8. Local arrays of variable length. These are converted to uses of +alloca, the array variable is replaced with a pointer to the allocated +array and the instances of sizeof(a) are adjusted to return the size of +the array and not the size of the pointer. +
  9. Non-constant local initializers. Like all local initializers these are +compiled into assignments. +
  10. Compound literals. These are also turned into assignments. +
  11. Designated initializers. The CIL parser actually supports the full ISO +syntax for initializers, which is more than both gcc and MSVC. I +(George) think that this is the most complicated part of the C language and +whoever designed it should be banned from ever designing languages again. +
  12. Case ranges. These are compiled into separate cases. There is no code +duplication, just a larger number of case statements. +
  13. Transparent unions. This is a strange feature that allows you to define +a function whose formal argument has a (tranparent) union type, but the +argument is called as if it were the first element of the union. This is +compiled away by saying that the type of the formal argument is that of the +first field, and the first thing in the function body we copy the formal into +a union.
    +
    +
  14. Inline assembly-language. The full syntax is supported and it is carried +as such in CIL.
    +
    +
  15. Function names as strings. The identifiers __FUNCTION__ and +__PRETTY_FUNCTION__ are replaced with string literals.
    +
    +
  16. Keywords typeof, alignof, inline are supported. +
+ + +

11  CIL Limitations

+ +There are several implementation details of CIL that might make it unusable + or less than ideal for certain tasks: +
  • +CIL operates after preprocessing. If you need to see comments, for +example, you cannot use CIL. But you can use attributes and pragmas instead. +And there is some support to help you patch the include files before they are +seen by the preprocessor. For example, this is how we turn some +#defines that we don't like into function calls.
    +
    +
  • CIL does transform the code in a non-trivial way. This is done in order +to make most analyses easier. But if you want to see the code e1, e2++ +exactly as it appears in the code, then you should not use CIL.
    +
    +
  • CIL removes all local scopes and moves all variables to function +scope. It also separates a declaration with an initializer into a declaration +plus an assignment. The unfortunate effect of this transformation is that +local variables cannot have the const qualifier.
+ + +

12  Known Bugs and Limitations

+ +
  • In the new versions of glibc there is a function + __builtin_va_arg that takes a type as its second argument. CIL + handles that through a slight trick. As it parses the function it changes a + call like: +
    +  mytype x = __builtin_va_arg(marker, mytype)
+
    into +
    + mytype x;
+ __builtin_va_arg(marker, sizeof(mytype), &x);
+
    + The latter form is used internally in CIL. However, the CIL pretty printer + will try to emit the original code.
    +
    +Similarly, __builtin_types_compatible_p(t1, t2), which takes + types as arguments, is represented internally as + __builtin_types_compatible_p(sizeof t1, sizeof t2), but the + sizeofs are removed when printing.
    +
    +
  • The implementation of bitsSizeOf does not take into account the +packing pragmas. However it was tested to be accurate on cygwin/gcc-2.95.3, +Linux/gcc-2.95.3 and on Windows/MSVC.
    +
    +
  • We do not support tri-graph sequences (ISO 5.2.1.1).
    +
    +
  • GCC has a strange feature called “extern inline”. Such a function can +be defined twice: first with the “extern inline” specifier and the second +time without it. If optimizations are turned off then the “extern inline” +definition is considered a prototype (its body is ignored). If optimizations +are turned on then the extern inline function is inlined at all of its +occurrences from the point of its definition all the way to the point where the +(optional) second definition appears. No body is generated for an extern +inline function. A body is generated for the real definition and that one is +used in the rest of the file.
    +
    +CIL will rename your extern inline function (and its uses) with the suffix + __extinline. This means that if you have two such definition, that do + different things and the optimizations are not on, then the CIL version might + compute a different answer !
    +
    +Also, if you have multiple extern inline declarations then CIL will ignore +but the first one. This is not so bad because GCC itself would not like it.
    +
    +
  • There are still a number of bugs in handling some obscure features of +GCC. For example, when you use variable-length arrays, CIL turns them into +calls to alloca. This means that they are deallocated when the function +returns and not when the local scope ends.
    +
    +Variable-length arrays are not supported as fields of a struct or union.
    +
    +
  • CIL cannot parse arbitrary #pragma directives. Their + syntax must follow gcc's attribute syntax to be understood. If you + need a pragma that does not follow gcc syntax, add that pragma's name + to no_parse_pragma in src/frontc/clexer.mll to indicate that + CIL should treat that pragma as a monolithic string rather than try + to parse its arguments.
    +
    +CIL cannot parse a line containing an empty #pragma.
    +
    +
  • CIL only parses #pragma directives at the "top level", this is, + outside of any enum, structure, union, or function definitions.
    +
    +If your compiler uses pragmas in places other than the top-level, + you may have to preprocess the sources in a special way (sed, perl, + etc.) to remove pragmas from these locations.
    +
    +
  • CIL cannot parse the following code (fixing this problem would require +extensive hacking of the LALR grammar): +
    
+int bar(int ()); // This prototype cannot be parsed
+int bar(int x()); // If you add a name to the function, it works
+int bar(int (*)()); // This also works (and it is more appropriate)
+

    +
    +
  • CIL also cannot parse certain K&R old-style prototypes with missing +return type: +
    
+g(); // This cannot be parsed
+int g(); // This is Ok
+

    +
    +
  • CIL does not understand some obscure combinations of type specifiers +(“signed” and “unsigned” applied to typedefs that themselves contain a +sign specification; you could argue that this should not be allowed anyway): +
    
+typedef signed char __s8;
+__s8 unsigned uchartest; // This is unsigned char for gcc
+

    +
    +
  • The statement x = 3 + x ++ will perform the increment of x + before the assignment, while gcc delays the increment after the + assignment. It turned out that this behavior is much easier to implement + than gcc's one, and either way is correct (since the behavior is unspecified + in this case). Similarly, if you write x = x ++; then CIL will perform + the increment before the assignment, whereas GCC and MSVC will perform it + after the assignment. +
+ + +

13  Using the merger

+ +
+
+There are many program analyses that are more effective when +done on the whole program.
+
+The merger is a tool that combines all of the C source files in a project +into a single C file. There are two tasks that a merger must perform: +
  1. +Detect what are all the sources that make a project and with what +compiler arguments they are compiled.
    +
    +
  2. Merge all of the source files into a single file. +
+For the first task the merger impersonates a compiler and a linker (both a +GCC and a Microsoft Visual C mode are supported) and it expects to be invoked +(from a build script or a Makefile) on all sources of the project. When +invoked to compile a source the merger just preprocesses the source and saves +the result using the name of the requested object file. By preprocessing at +this time the merger is able to take into account variations in the command +line arguments that affect preprocessing of different source files.
+
+When the merger is invoked to link a number of object files it collects the +preprocessed sources that were stored with the names of the object files, and +invokes the merger proper. Note that arguments that affect the compilation or +linking must be the same for all source files.
+
+For the second task, the merger essentially concatenates the preprocessed +sources with care to rename conflicting file-local declarations (we call this +process alpha-conversion of a file). The merger also attempts to remove +duplicate global declarations and definitions. Specifically the following +actions are taken: +
  • +File-scope names (static globals, names of types defined with +typedef, and structure/union/enumeration tags) are given new names if they +conflict with declarations from previously processed sources. The new name is +formed by appending the suffix ___n, where n is a unique integer +identifier. Then the new names are applied to their occurrences in the file.
    +
    +
  • Non-static declarations and definitions of globals are never renamed. +But we try to remove duplicate ones. Equality of globals is detected by +comparing the printed form of the global (ignoring the line number directives) +after the body has been alpha-converted. This process is intended to remove +those declarations (e.g. function prototypes) that originate from the same +include file. Similarly, we try to eliminate duplicate definitions of +inline functions, since these occasionally appear in include files.
    +
    +
  • The types of all global declarations with the same name from all files +are compared for type isomorphism. During this process, the merger detects all +those isomorphisms between structures and type definitions that are required for the merged program to be legal. Such structure tags and +typenames are coalesced and given the same name.
    +
    +
  • Besides the structure tags and type names that are required to be +isomorphic, the merger also tries to coalesce definitions of structures and +types with the same name from different file. However, in this case the merger +will not give an error if such definitions are not isomorphic; it will just +use different names for them.
    +
    +
  • In rare situations, it can happen that a file-local global in +encountered first and it is not renamed, only to discover later when +processing another file that there is an external symbol with the same name. +In this case, a second pass is made over the merged file to rename the +file-local symbol. +
+Here is an example of using the merger:
+
+The contents of file1.c is: +

+struct foo; // Forward declaration
+extern struct foo *global;
+
+The contents of file2.c is: +

+struct bar {
+ int x;
+ struct bar *next;
+};
+extern struct bar *global;
+struct foo {
+ int y;
+};
+extern struct foo another;
+void main() {
+}
+
+There are several ways in which one might create an executable from these +files: +
  • +
    +gcc file1.c file2.c -o a.out
+

    +
    +
  • +gcc -c file1.c -o file1.o
+gcc -c file2.c -o file2.o
+ld file1.o file2.o -o a.out
+

    +
    +
  • +gcc -c file1.c -o file1.o
+gcc -c file2.c -o file2.o
+ar r libfile2.a file2.o
+gcc file1.o libfile2.a -o a.out
+

    +
    +
  • +gcc -c file1.c -o file1.o
+gcc -c file2.c -o file2.o
+ar r libfile2.a file2.o
+gcc file1.o -lfile2 -o a.out
+
+In each of the cases above you must replace all occurrences of gcc and +ld with cilly --merge, and all occurrences of ar with cilly +--merge --mode=AR. It is very important that the --merge flag be used +throughout the build process. If you want to see the merged source file you +must also pass the --keepmerged flag to the linking phase.
+
+The result of merging file1.c and file2.c is: +

+// from file1.c
+struct foo; // Forward declaration
+extern struct foo *global;
+
+// from file2.c
+struct foo {
+ int x;
+ struct foo *next;
+};
+struct foo___1 {
+ int y;
+};
+extern struct foo___1 another;
+
+ + +

14  Using the patcher

+ +
+
+Occasionally we have needed to modify slightly the standard include files. +So, we developed a simple mechanism that allows us to create modified copies +of the include files and use them instead of the standard ones. For this +purpose we specify a patch file and we run a program caller Patcher which +makes modified copies of include files and applies the patch.
+
+The patcher is invoked as follows: +
+bin/patcher [options]
+
+Options:
+  --help       Prints this help message
+  --verbose    Prints a lot of information about what is being done
+  --mode=xxx   What tool to emulate: 
+                GNUCC     - GNU CC
+                MSVC      - MS VC cl compiler
+
+  --dest=xxx   The destination directory. Will make one if it does not exist
+  --patch=xxx  Patch file (can be specified multiple times)
+  --ppargs=xxx An argument to be passed to the preprocessor (can be specified
+               multiple times)
+
+  --ufile=xxx  A user-include file to be patched (treated as \#include "xxx")
+  --sfile=xxx  A system-include file to be patched (treated as \#include <xxx>)
+ 
+  --clean       Remove all files in the destination directory
+  --dumpversion Print the version name used for the current compiler
+
+ All of the other arguments are passed to the preprocessor. You should pass
+ enough arguments (e.g., include directories) so that the patcher can find the
+ right include files to be patched.
+
+ Based on the given mode and the current version of the compiler (which +the patcher can print when given the dumpversion argument) the patcher +will create a subdirectory of the dest directory (say /usr/home/necula/cil/include), such as: +
+/usr/home/necula/cil/include/gcc_2.95.3-5
+
+ In that file the patcher will copy the modified versions of the include files +specified with the ufile and sfile options. Each of these options can +be specified multiple times.
+
+The patch file (specified with the patch option) has a format inspired by +the Unix patch tool. The file has the following grammar: +
+<<< flags
+patterns
+===
+replacement
+>>>
+
+ The flags are a comma separated, case-sensitive, sequence of keywords or +keyword = value. The following flags are supported: +
  • +file=foo.h - will only apply the patch on files whose name is + foo.h. +
  • optional - this means that it is Ok if the current patch does not +match any of the processed files. +
  • group=foo - will add this patch to the named group. If this is not +specified then a unique group is created to contain just the current patch. +When all files specified in the command line have been patched, an error +message is generated for all groups for whom no member patch was used. We use +this mechanism to receive notice when the patch triggers are out-dated with +respect to the new include files. +
  • system=sysname - will only consider this pattern on a given +operating system. The “sysname” is reported by the “$Ô” variable in +Perl, except that Windows is always considered to have sysname +“cygwin.” For Linux use “linux” (capitalization matters). +
  • ateof - In this case the patterns are ignored and the replacement +text is placed at the end of the patched file. Use the file flag if you +want to restrict the files in which this replacement is performed. +
  • atsof - The patterns are ignored and the replacement text is placed +at the start of the patched file. Uf the file flag to restrict the +application of this patch to a certain file. +
  • disabled - Use this flag if you want to disable the pattern. +
+The patterns can consist of several groups of lines separated by the ||| +marker. Each of these group of lines is a multi-line pattern that if found in +the file will be replaced with the text given at the end of the block.
+
+The matching is space-insensitive.
+
+All of the markers <<<, |||, === and >>> must appear at the +beginning of a line but they can be followed by arbitrary text (which is +ignored).
+
+The replacement text can contain the special keyword @__pattern__@, +which is substituted with the pattern that matched.
+
+ + +

15  Debugging support

+ +Most of the time we debug our code using the Errormsg module along with the +pretty printer. But if you want to use the Ocaml debugger here is an easy way +to do it. Say that you want to debug the invocation of cilly that arises out +of the following command: +
+cilly -c hello.c 
+
+ You must follow the installation instructions +to install the Elist support files for ocaml and to extend your .emacs +appropriately. Then from within Emacs you do +
+ALT-X my-camldebug
+
+ This will ask you for the command to use for running the Ocaml debugger +(initially the default will be “ocamldebug” or the last command you +introduced). You use the following command: +
+cilly --ocamldebug -c hello.c 
+
+ This will run cilly as usual and invoke the Ocaml debugger when the cilly +engine starts. The advantage of this way of invoking the debugger is that the +directory search paths are set automatically and the right set or arguments is +passed to the debugger.
+
+ + +

16  Who Says C is Simple?

+ +When I (George) started to write CIL I thought it was going to take two weeks. +Exactly a year has passed since then and I am still fixing bugs in it. This +gross underestimate was due to the fact that I thought parsing and making +sense of C is simple. You probably think the same. What I did not expect was +how many dark corners this language has, especially if you want to parse +real-world programs such as those written for GCC or if you are more ambitious +and you want to parse the Linux or Windows NT sources (both of these were +written without any respect for the standard and with the expectation that +compilers will be changed to accommodate the program).
+
+The following examples were actually encountered either in real programs or +are taken from the ISO C99 standard or from the GCC's testcases. My first +reaction when I saw these was: Is this C?. The second one was : What the hell does it mean?.
+
+If you are contemplating doing program analysis for C on abstract-syntax +trees then your analysis ought to be able to handle these things. Or, you can +use CIL and let CIL translate them into clean C code.
+
+ + +

16.1  Standard C

+ +
  1. Why does the following code return 0 for most values of x? (This +should be easy.) +
    
+  int x;
+  return x == (1 && x);
+
    +See the CIL output for this +code fragment
    +
    +
  2. Why does the following code return 0 and not -1? (Answer: because +sizeof is unsigned, thus the result of the subtraction is unsigned, thus +the shift is logical.) +
    
+ return ((1 - sizeof(int)) >> 32);
+
    +See the CIL output for this +code fragment
    +
    +
  3. Scoping rules can be tricky. This function returns 5. +
    
+int x = 5;
+int f() {
+  int x = 3;
+  {
+    extern int x;
+    return x;
+  }
+}
+
    +See the CIL output for this +code fragment
    +
    +
  4. Functions and function pointers are implicitly converted to each other. +
    
+int (*pf)(void);
+int f(void) {
+
+   pf = &f; // This looks ok
+   pf = ***f; // Dereference a function?
+   pf(); // Invoke a function pointer?     
+   (****pf)();  // Looks strange but Ok
+   (***************f)(); // Also Ok             
+}
+
    +See the CIL output for this +code fragment
    +
    +
  5. Initializer with designators are one of the hardest parts about ISO C. +Neither MSVC or GCC implement them fully. GCC comes close though. What is the +final value of i.nested.y and i.nested.z? (Answer: 2 and respectively +6). +
    
+struct { 
+   int x; 
+   struct { 
+       int y, z; 
+   } nested;
+} i = { .nested.y = 5, 6, .x = 1, 2 };               
+
    +See the CIL output for this +code fragment
    +
    +
  6. This is from c-torture. This function returns 1. +
    
+typedef struct
+{
+  char *key;
+  char *value;
+} T1;
+
+typedef struct
+{
+  long type;
+  char *value;
+} T3;
+
+T1 a[] =
+{
+  {
+    "",
+    ((char *)&((T3) {1, (char *) 1}))
+  }
+};
+int main() {
+   T3 *pt3 = (T3*)a[0].value;
+   return pt3->value;
+}
+
    +See the CIL output for this +code fragment
    +
    +
  7. Another one with constructed literals. This one is legal according to +the GCC documentation but somehow GCC chokes on (it works in CIL though). This +code returns 2. +
    
+ return ((int []){1,2,3,4})[1];
+
    +See the CIL output for this +code fragment
    +
    +
  8. In the example below there is one copy of “bar” and two copies of + “pbar” (static prototypes at block scope have file scope, while for all + other types they have block scope). +
    
+  int foo() {
+     static bar();
+     static (*pbar)() = bar;
+
+  }
+
+  static bar() { 
+    return 1;
+  }
+
+  static (*pbar)() = 0;
+
    +See the CIL output for this +code fragment
    +
    +
  9. Two years after heavy use of CIL, by us and others, I discovered a bug + in the parser. The return value of the following function depends on what + precedence you give to casts and unary minus: +
    
+  unsigned long foo() {
+    return (unsigned long) - 1 / 8;
+  }
+
    +See the CIL output for this +code fragment
    +
    +The correct interpretation is ((unsigned long) - 1) / 8, which is a + relatively large number, as opposed to (unsigned long) (- 1 / 8), which + is 0.
+ + +

16.2  GCC ugliness

+ +
  1. GCC has generalized lvalues. You can take the address of a lot of +strange things: +
    
+  int x, y, z;
+  return &(x ? y : z) - & (x++, x);
+
    +See the CIL output for this +code fragment
    +
    +
  2. GCC lets you omit the second component of a conditional expression. +
    
+  extern int f();
+  return f() ? : -1; // Returns the result of f unless it is 0
+
    +See the CIL output for this +code fragment
    +
    +
  3. Computed jumps can be tricky. CIL compiles them away in a fairly clean +way but you are on your own if you try to jump into another function this way. +
    
+static void *jtab[2]; // A jump table
+static int doit(int x){
+ 
+  static int jtab_init = 0;
+  if(!jtab_init) { // Initialize the jump table
+    jtab[0] = &&lbl1;
+    jtab[1] = &&lbl2;
+    jtab_init = 1;
+  }
+  goto *jtab[x]; // Jump through the table
+lbl1:
+  return 0;
+lbl2:
+  return 1;
+}
+ 
+int main(void){
+  if (doit(0) != 0) exit(1);
+  if (doit(1) != 1) exit(1);
+  exit(0);
+}
+
    +See the CIL output for this +code fragment
    +
    +
  4. A cute little example that we made up. What is the returned value? +(Answer: 1); +
    
+ return ({goto L; 0;}) && ({L: 5;});
+
    +See the CIL output for this +code fragment
    +
    +
  5. extern inline is a strange feature of GNU C. Can you guess what the +following code computes? +
    
+extern inline foo(void) { return 1; }
+int firstuse(void) { return foo(); }
+
+// A second, incompatible definition of foo
+int foo(void) { return 2; }
+
+int main() {
+    return foo() + firstuse();
+}
+
    +See the CIL output for this +code fragment
    +
    +The answer depends on whether the optimizations are turned on. If they are +then the answer is 3 (the first definition is inlined at all occurrences until +the second definition). If the optimizations are off, then the first +definition is ignore (treated like a prototype) and the answer is 4.
    +
    +CIL will misbehave on this example, if the optimizations are turned off (it + always returns 3).
    +
    +
  6. GCC allows you to cast an object of a type T into a union as long as the +union has a field of that type: +
    
+union u { 
+   int i; 
+   struct s { 
+      int i1, i2;
+   } s;
+};
+
+union u x = (union u)6;
+
+int main() {
+  struct s y = {1, 2};
+  union u  z = (union u)y;
+}
+
    +See the CIL output for this +code fragment
    +
    +
  7. GCC allows you to use the __mode__ attribute to specify the size +of the integer instead of the standard char, short and so on: +
    
+int __attribute__ ((__mode__ (  __QI__ ))) i8;
+int __attribute__ ((__mode__ (  __HI__ ))) i16;
+int __attribute__ ((__mode__ (  __SI__ ))) i32;
+int __attribute__ ((__mode__ (  __DI__ ))) i64;
+
    +See the CIL output for this +code fragment
    +
    +
  8. The “alias” attribute on a function declaration tells the + linker to treat this declaration as another name for the specified + function. CIL will replace the declaration with a trampoline + function pointing to the specified target. +
    
+    static int bar(int x, char y) {
+      return x + y;
+    }
+
+    //foo is considered another name for bar.
+    int foo(int x, char y) __attribute__((alias("bar")));
+
    +See the CIL output for this +code fragment
+ + +

16.3  Microsoft VC ugliness

+ +This compiler has few extensions, so there is not much to say here. +
  1. +Why does the following code return 0 and not -1? (Answer: because of a +bug in Microsoft Visual C. It thinks that the shift is unsigned just because +the second operator is unsigned. CIL reproduces this bug when in MSVC mode.) +
    
+ return -3 >> (8 * sizeof(int));
+

    +
    +
  2. Unnamed fields in a structure seem really strange at first. It seems +that Microsoft Visual C introduced this extension, then GCC picked it up (but +in the process implemented it wrongly: in GCC the field y overlaps with +x!). +
    
+struct {
+  int x;
+  struct {
+     int y, z;
+     struct {
+       int u, v;
+     };
+ };
+} a;
+return a.x + a.y + a.z + a.u + a.v;
+
    +See the CIL output for this +code fragment
+ + +

17  Authors

+ +The CIL parser was developed starting from Hugues Casse's frontc +front-end for C although all the files from the frontc distribution have +been changed very extensively. The intermediate language and the elaboration +stage are all written from scratch. The main author is +George Necula, with significant +contributions from Scott McPeak, +Westley Weimer, +Ben Liblit, +Matt Harren, +Raymond To and Aman Bhargava.
+
+This work is based upon work supported in part by the National Science +Foundation under Grants No. 9875171, 0085949 and 0081588, and gifts from +Microsoft Research. Any opinions, findings, and conclusions or recommendations +expressed in this material are those of the author(s) and do not necessarily +reflect the views of the National Science Foundation or the other sponsors.
+
+ + +

18  License

+ +Copyright (c) 2001-2005, +
  • +George C. Necula <necula@cs.berkeley.edu> +
  • Scott McPeak <smcpeak@cs.berkeley.edu> +
  • Wes Weimer <weimer@cs.berkeley.edu> +
  • Ben Liblit <liblit@cs.wisc.edu> +
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution.
+
+3. The names of the contributors may not be used to endorse or promote +products derived from this software without specific prior written +permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE.
+
+ + +

19  Bug reports

+ +We are certain that there are still some remaining bugs in CIL. If you find +one please file a bug report in our Source Forge space +http://sourceforge.net/projects/cil.
+
+You can find there the latest announcements, a source distribution, +bug report submission instructions and a mailing list: cil-users[at +sign]lists.sourceforge.net. Please use this list to ask questions about CIL, +as it will ensure your message is viewed by a broad audience.
+
+ + +

20  Changes

+ + +
  • +May 20, 2006: Released version 1.3.5 +
  • May 19, 2006: Makefile.cil.in/Makefile.cil have + been renamed Makefile.in/Makefile. And maincil.ml has + been renamed main.ml. +
  • May 18, 2006: Added a new module Cfg to compute the + control-flow graph. Unlike the older Cil.computeCFGInfo, + the new version does not modify the code. +
  • May 18, 2006: Added several new analyses: reaching + definitions, available expressions, liveness analysis, and dead code + elimination. See Section 8. +
  • May 2, 2006: Added a flag --noInsertImplicitCasts. + When this flag is used, CIL code will only include casts inserted by + the programmer. Implicit coercions are not changed to explicit casts. +
  • April 16, 2006: Minor improvements to the --stats + flag (Section 7.2). We now use Pentium performance + counters by default, if your processor supports them. +
  • April 10, 2006: Extended machdep.c to support + microcontroller compilers where the struct alignment of integer + types does not match the size of the type. Thanks to Nathan + Cooprider for the patch. +
  • April 6, 2006: Fix for global initializers of unions when + the union field being initialized is not the first one, and for + missing initializers of unions when the first field is not the + largest field. +
  • April 6, 2006: Fix for bitfields in the SFI module. +
  • April 6, 2006: Various fixes for gcc attributes. + packed, section, and always_inline attributes are now + parsed correctly. Also fixed printing of attributes on enum types. +
  • March 30, 2006: Fix for rmtemps.ml, which deletes + unused inline functions. When in gcc mode CIL now leaves all + inline functions in place, since gcc treats these as externally + visible. +
  • March 15, 2006: Fix for typeof(e) when e has type + void. +
  • March 3, 2006: Assume inline assembly instructions can + fall through for the purposes of adding return statements. Thanks to + Nathan Cooprider for the patch. +
  • February 27, 2006: Fix for extern inline functions when + the output of CIL is fed back into CIL. +
  • January 30, 2006: Fix parsing of switch without braces. +
  • January 30, 2006: Allow `$' to appear in identifiers. +
  • January 13, 2006: Added support for gcc's alias attribute + on functions. See Section 16.2, item 8. +
  • December 9, 2005: Christoph Spiel fixed the Golf and + Olf modules so that Golf can be used with the points-to analysis. + He also added performance fixes and cleaned up the documentation. +
  • December 1, 2005: Major rewrite of the ext/callgraph module. +
  • December 1, 2005: Preserve enumeration constants in CIL. Default +is the old behavior to replace them with integers. +
  • November 30, 2005: Added support for many GCC __builtin + functions. +
  • November 30, 2005: Added the EXTRAFEATURES configure + option, making it easier to add Features to the build process. +
  • November 23, 2005: In MSVC mode do not remove any locals whose name + appears as a substring in an inline assembly. +
  • November 23, 2005: Do not add a return to functions that have the + noreturn attribute. +
  • November 22, 2005: Released version 1.3.4 +
  • November 21, 2005: Performance and correctness fixes for + the Points-to Analysis module. Thanks to Christoph Spiel for the + patches. +
  • October 5, 2005: CIL now builds on SPARC/Solaris. Thanks + to Nick Petroni and Remco van Engelen for the patches. +
  • September 26, 2005: CIL no longer uses the `-I-' flag + by default when preprocessing with gcc. +
  • August 24, 2005: Added a command-line option + “--forceRLArgEval” that forces function arguments to be evaluated + right-to-left. This is the default behavior in unoptimized gcc and + MSVC, but the order of evaluation is undefined when using + optimizations, unless you apply this CIL transformation. This flag + does not affect the order of evaluation of e.g. binary operators, + which remains undefined. Thanks to Nathan Cooprider for the patch. +
  • August 9, 2005: Fixed merging when there are more than 20 + input files. +
  • August 3, 2005: When merging, it is now an error to + declare the same global variable twice with different initializers. +
  • July 27, 2005: Fixed bug in transparent unions. +
  • July 27, 2005: Fixed bug in collectInitializer. Thanks to + Benjamin Monate for the patch. +
  • July 26, 2005: Better support for extended inline assembly + in gcc. +
  • July 26, 2005: Added many more gcc __builtin* functions + to CIL. Most are treated as Call instructions, but a few are + translated into expressions so that they can be used in global + initializers. For example, “__builtin_offsetof(t, field)” is + rewritten as “&((t*)0)->field”, the traditional way of calculating + an offset. +
  • July 18, 2005: Fixed bug in the constant folding of shifts + when the second argument was negative or too large. +
  • July 18, 2005: Fixed bug where casts were not always + inserted in function calls. +
  • June 10, 2005: Fixed bug in the code that makes implicit + returns explicit. We weren't handling switch blocks correctly. +
  • June 1, 2005: Released version 1.3.3 +
  • May 31, 2005: Fixed handling of noreturn attribute for function + pointers. +
  • May 30, 2005: Fixed bugs in the handling of constructors in gcc. +
  • May 30, 2005: Fixed bugs in the generation of global variable IDs. +
  • May 27, 2005: Reimplemented the translation of function calls so + that we can intercept some builtins. This is important for the uses of + __builtin_constant_p in constants. +
  • May 27, 2005: Export the plainCilPrinter, for debugging. +
  • May 27, 2005: Fixed bug with printing of const attribute for + arrays. +
  • May 27, 2005: Fixed bug in generation of type signatures. Now they + should not contain expressions anymore, so you can use structural equality. + This used to lead to Out_of_Memory exceptions. +
  • May 27, 2005: Fixed bug in type comparisons using + TBuiltin_va_list. +
  • May 27, 2005: Improved the constant folding in array lengths and + case expressions. +
  • May 27, 2005: Added the __builtin_frame_address to the set + of gcc builtins. +
  • May 27, 2005: Added the CIL project to SourceForge. +
  • April 23, 2005: The cattr field was not visited. +
  • March 6, 2005: Debian packaging support +
  • February 16, 2005: Merger fixes. +
  • February 11, 2005: Fixed a bug in --dopartial. Thanks to +Nathan Cooprider for this fix. +
  • January 31, 2005: Make sure the input file is closed even if a + parsing error is encountered. +
  • January 11, 2005: Released version 1.3.2 +
  • January 11, 2005: Fixed printing of integer constants whose + integer kind is shorter than an int. +
  • January 11, 2005: Added checks for negative size arrays and arrays + too big. +
  • January 10, 2005: Added support for GCC attribute “volatile” for + tunctions (as a synonim for noreturn). +
  • January 10, 2005: Improved the comparison of array sizes when + comparing array types. +
  • January 10, 2005: Fixed handling of shell metacharacters in the + cilly command lione. +
  • January 10, 2005: Fixed dropping of cast in initialization of + local variable with the result of a function call. +
  • January 10, 2005: Fixed some structural comparisons that were + broken in the Ocaml 3.08. +
  • January 10, 2005: Fixed the unrollType function to not forget + attributes. +
  • January 10, 2005: Better keeping track of locations of function + prototypes and definitions. +
  • January 10, 2005: Fixed bug with the expansion of enumeration + constants in attributes. +
  • October 18, 2004: Fixed a bug in cabsvisit.ml. CIl would wrap a + BLOCK around a single atom unnecessarily. +
  • August 7, 2004: Released version 1.3.1 +
  • August 4, 2004: Fixed a bug in splitting of structs using + --dosimplify +
  • July 29, 2004: Minor changes to the type typeSig (type signatures) + to ensure that they do not contain types, so that you can do structural + comparison without danger of nontermination. +
  • July 28, 2004: Ocaml version 3.08 is required. Numerous small + changes while porting to Ocaml 3.08. +
  • July 7, 2004: Released version 1.2.6 +
  • July 2, 2004: Character constants such as 'c' should + have type int, not char. Added a utility function + Cil.charConstToInt that sign-extends chars greater than 128, if needed. +
  • July 2, 2004: Fixed a bug that was casting values to int + before applying the logical negation operator !. This caused + problems for floats, and for integer types bigger than int. +
  • June 13, 2004: Added the field sallstmts to a function + description, to hold all statements in the function. +
  • June 13, 2004: Added new extensions for data flow analyses, and + for computing dominators. +
  • June 10, 2004: Force initialization of CIL at the start of +Cabs2cil. +
  • June 9, 2004: Added support for GCC __attribute_used__ +
  • April 7, 2004: Released version 1.2.5 +
  • April 7, 2004: Allow now to run ./configure CC=cl and set the MSVC +compiler to be the default. The MSVC driver will now select the default name +of the .exe file like the CL compiler. +
  • April 7, 2004: Fixed a bug in the driver. The temporary files are +deleted by the Perl script before the CL compiler gets to them? +
  • April 7, 2004: Added the - form of arguments to the MSVC driver. +
  • April 7, 2004: Added a few more GCC-specific string escapes, (, [, +{, %, E. +
  • April 7, 2004: Fixed bug with continuation lines in MSVC. +
  • April 6, 2004: Fixed embarassing bug in the parser: the precedence + of casts and unary operators was switched. +
  • April 5, 2004: Fixed a bug involving statements mixed between +declarations containing initializers. Now we make sure that the initializers +are run in the proper order with respect to the statements. +
  • April 5, 2004: Fixed a bug in the merger. The merger was keeping +separate alpha renaming talbes (namespaces) for variables and types. This +means that it might end up with a type and a variable named the same way, if +they come from different files, which breaks an important CIL invariant. +
  • March 11, 2004 : Fixed a bug in the Cil.copyFunction function. The +new local variables were not getting fresh IDs. +
  • March 5, 2004: Fixed a bug in the handling of static function + prototypes in a block scope. They used to be renamed. Now we just consider + them global. +
  • February 20, 2004: Released version 1.2.4 +
  • February 15, 2004: Changed the parser to allow extra semicolons + after field declarations. +
  • February 14, 2004: Changed the Errormsg functions: error, unimp, +bug to not raise an exception. Instead they just set Errormsg.hadErrors. +
  • February 13, 2004: Change the parsing of attributes to recognize + enumeration constants. +
  • February 10, 2004: In some versions of gcc the identifier + _{thread is an identifier and in others it is a keyword. Added code + during configuration to detect which is the case. +
  • January 7, 2004: Released version 1.2.3 +
  • January 7, 2004: Changed the alpha renamer to be less +conservative. It will remember all versions of a name that were seen and will +only create a new name if we have not seen one. +
  • December 30, 2003 : Extended the cilly command to understand + better linker command options -lfoo. +
  • December 5, 2003: Added markup commands to the pretty-printer +module. Also, changed the “@<” left-flush command into “@''. +
  • December 4, 2003: Wide string literals are now handled +directly by Cil (rather than being exploded into arrays). This is +apparently handy for Microsoft Device Driver APIs that use intrinsic +functions that require literal constant wide-string arguments. +
  • December 3, 2003: Added support for structured exception handling + extensions for the Microsoft compilers. +
  • December 1, 2003: Fixed a Makefile bug in the generation of the +Cil library (e.g., cil.cma) that was causing it to be unusable. Thanks +to KEvin Millikin for pointing out this bug. +
  • November 26, 2003: Added support for linkage specifications + (extern “C”). +
  • November 26, 2003: Added the ocamlutil directory to contain some +utilities shared with other projects. +
  • November 25, 2003: Released version 1.2.2 +
  • November 24, 2003: Fixed a bug that allowed a static local to + conflict with a global with the same name that is declared later in the + file. +
  • November 24, 2003: Removed the --keep option of the cilly + driver and replaced it with --save-temps. +
  • November 24, 2003: Added printing of what CIL features are being + run. +
  • November 24, 2003: Fixed a bug that resulted in attributes being + dropped for integer types. +
  • November 11, 2003: Fixed a bug in the visitor for enumeration + definitions. +
  • October 24, 2003: Fixed a problem in the configuration script. It + was not recognizing the Ocaml version number for beta versions. +
  • October 15, 2003: Fixed a problem in version 1.2.1 that was + preventing compilation on OCaml 3.04. +
  • September 17, 2003: Released version 1.2.1. +
  • September 7, 2003: Redesigned the interface for choosing + #line directive printing styles. Cil.printLn and + Cil.printLnComment have been merged into Cil.lineDirectiveStyle. +
  • August 8, 2003: Do not silently pad out functions calls with +arguments to match the prototype. +
  • August 1, 2003: A variety of fixes suggested by Steve Chamberlain: +initializers for externs, prohibit float literals in enum, initializers for +unsized arrays were not working always, an overflow problem in Ocaml, changed +the processing of attributes before struct specifiers
    +
    +
  • July 14, 2003: Add basic support for GCC's "__thread" storage +qualifier. If given, it will appear as a "thread" attribute at the top of the +type of the declared object. Treatment is very similar to "__declspec(...)" +in MSVC
    +
    +
  • July 8, 2003: Fixed some of the __alignof computations. Fixed + bug in the designated initializers for arrays (Array.get error). +
  • July 8, 2003: Fixed infinite loop bug (Stack Overflow) in the + visitor for __alignof. +
  • July 8, 2003: Fixed bug in the conversion to CIL. A function or + array argument of + the GCC __typeof() was being converted to pointer type. Instead, it should + be left alone, just like for sizeof. +
  • July 7, 2003: New Escape module provides utility functions + for escaping characters and strings in accordance with C lexical + rules.
    +
    +
  • July 2, 2003: Relax CIL's rules for when two enumeration types are +considered compatible. Previously CIL considered two enums to be compatible if +they were the same enum. Now we follow the C99 standard.
    +
    +
  • June 28, 2003: In the Formatparse module, Eric Haugh found and + fixed a bug in the handling of lvalues of the form “lv->field.more”.
    +
    +
  • June 28, 2003: Extended the handling of gcc command lines +arguments in the Perl scripts.
    +
    +
  • June 23, 2003: In Rmtmps module, simplified the API for + customizing the root set. Clients may supply a predicate that + returns true for each root global. Modifying various + “referenced” fields directly is no longer supported.
    +
    +
  • June 17, 2003: Reimplement internal utility routine + Cil.escape_char. Faster and better.
    +
    +
  • June 14, 2003: Implemented support for __attribute__s +appearing between "struct" and the struct tag name (also for unions and +enums), since gcc supports this as documented in section 4.30 of the gcc +(2.95.3) manual
    +
    +
  • May 30, 2003: Released the regression tests. +
  • May 28, 2003: Released version 1.1.2 +
  • May 26, 2003: Add the simplify module that compiles CIL +expressions into simpler expressions, similar to those that appear in a +3-address intermediate language. +
  • May 26, 2003: Various fixes and improvements to the pointer +analysis modules. +
  • May 26, 2003: Added optional consistency checking for +transformations. +
  • May 25, 2003: Added configuration support for big endian machines. +Now Cil.little_endian can be used to test whether the machine is +little endian or not. +
  • May 22, 2003: Fixed a bug in the handling of inline functions. The +CIL merger used to turn these functions into “static”, which is incorrect. +
  • May 22, 2003: Expanded the CIL consistency checker to verify +undesired sharing relationships between data structures. +
  • May 22, 2003: Fixed bug in the oneret CIL module: it was +mishandling certain labeled return statements. +
  • May 5, 2003: Released version 1.0.11 +
  • May 5, 2003: OS X (powerpc/darwin) support for CIL. Special +thanks to Jeff Foster, Andy Begel and Tim Leek. +
  • April 30, 2003: Better description of how to use CIL for your +analysis. +
  • April 28, 2003: Fixed a bug with --dooneRet and +--doheapify. Thanks, Manos Renieris. +
  • April 16, 2003: Reworked management of + temporary/intermediate output files in Perl driver scripts. Default + behavior is now to remove all such files. To keep intermediate + files, use one of the following existing flags: +
    • + --keepmerged for the single-file merge of all sources +
    • --keep=<dir> for various other CIL and + CCured output files +
    • --save-temps for various gcc intermediate files; MSVC + has no equivalent option +
    + As part of this change, some intermediate files have changed their + names slightly so that new suffixes are always preceded by a + period. For example, CCured output that used to appear in + “foocured.c” now appears in “foo.cured.c”. +
  • April 7, 2003: Changed the representation of the Cil.GVar +global constructor. Now it is possible to update the initializer without +reconstructing the global (which in turn it would require reconstructing the +list of globals that make up a program). We did this because it is often +tempting to use Cil.visitCilFileSameGlobals and the Cil.GVar +was the only global that could not be updated in place. +
  • April 6, 2003: Reimplemented parts of the cilly.pl script to make +it more robust in the presence of complex compiler arguments. +
  • March 10, 2003: Released version 1.0.9 +
  • March 10, 2003: Unified and documented a large number of CIL +Library Modules: oneret, simplemem, makecfg, heapify, stackguard, partial. +Also documented the main client interface for the pointer analysis. +
  • February 18, 2003: Fixed a bug in logwrites that was causing it +to produce invalid C code on writes to bitfields. Thanks, David Park. +
  • February 15, 2003: Released version 1.0.8 +
  • February 15, 2003: PDF versions of the manual and API are +available for those who would like to print them out. +
  • February 14, 2003: CIL now comes bundled with alias analyses. +
  • February 11, 2003: Added support for adding/removing options from + ./configure. +
  • February 3, 2003: Released version 1.0.7 +
  • February 1, 2003: Some bug fixes in the handling of variable +argument functions in new versions of gcc And glibc. +
  • January 29, 2003: Added the logical AND and OR operators. +Exapanded the translation to CIL to handle more complicated initializers +(including those that contain logical operators). +
  • January 28, 2003: Released version 1.0.6 +
  • January 28, 2003: Added support for the new handling of +variable-argument functions in new versions of glibc. +
  • January 19, 2003: Added support for declarations in interpreted + constructors. Relaxed the semantics of the patterns for variables. +
  • January 17, 2003: Added built-in prototypes for the gcc built-in + functions. Changed the pGlobal method in the printers to print the + carriage return as well. +
  • January 9, 2003: Reworked lexer and parser's strategy for + tracking source file names and line numbers to more closely match + typical native compiler behavior. The visible CIL interface is + unchanged. +
  • January 9, 2003: Changed the interface to the alpha convertor. Now +you can pass a list where it will record undo information that you can use to +revert the changes that it makes to the scope tables. +
  • January 6, 2003: Released version 1.0.5 +
  • January 4, 2003: Changed the interface for the Formatcil module. + Now the placeholders in the pattern have names. Also expanded the + documentation of the Formatcil module. + Now the placeholders in the pattern have names. +
  • January 3, 2003: Extended the rmtmps module to also remove + unused labels that are generated in the conversion to CIL. This reduces the + number of warnings that you get from cgcc afterwards. +
  • December 17, 2002: Fixed a few bugs in CIL related to the + representation of string literals. The standard says that a string literal + is an array. In CIL, a string literal has type pointer to character. This is + Ok, except as an argument of sizeof. To support this exception, we have + added to CIL the expression constructor SizeOfStr. This allowed us to fix + bugs with computing sizeof("foo bar") and sizeof((char*)"foo bar") + (the former is 8 and the latter is 4).
    +
    +
  • December 8, 2002: Fixed a few bugs in the lexer and parser + relating to hex and octal escapes in string literals. Also fixed + the dependencies between the lexer and parser. +
  • December 5, 2002: Fixed visitor bugs that were causing + some attributes not to be visited and some queued instructions to be + dropped. +
  • December 3, 2002: Added a transformation to catch stack + overflows. Fixed the heapify transformation. +
  • October 14, 2002: CIL is now available under the BSD license +(see the License section or the file LICENSE). Released version 1.0.4 +
  • October 9, 2002: More FreeBSD configuration changes, support +for the GCC-ims __signed and __volatile. Thanks to Axel +Simon for pointing out these problems. Released version 1.0.3 +
  • October 8, 2002: FreeBSD configuration and porting fixes. +Thanks to Axel Simon for pointing out these problems. +
  • September 10, 2002: Fixed bug in conversion to CIL. Now we drop +all “const” qualifiers from the types of locals, even from the fields of +local structures or elements of arrays. +
  • September 7, 2002: Extended visitor interface to distinguish visitng + offsets inside lvalues from offsets inside initializer lists. +
  • September 7, 2002: Released version 1.0.1 +
  • September 6, 2002: Extended the patcher with the ateof flag. +
  • September 4, 2002: Fixed bug in the elaboration to CIL. In some +cases constant folding of || and && was computed wrong. +
  • September 3, 2002: Fixed the merger documentation. +
  • August 29, 2002: Released version 1.0.0. +
  • August 29, 2002: Started numbering versions with a major nubmer, +minor and revisions. Released version 1.0.0. +
  • August 25, 2002: Fixed the implementation of the unique +identifiers for global variables and composites. Now those identifiers are +globally unique. +
  • August 24, 2002: Added to the machine-dependent configuration the +sizeofvoid. It is 1 on gcc and 0 on MSVC. Extended the implementation of +Cil.bitsSizeOf to handle this (it was previously returning an error when +trying to compute the size of void). +
  • August 24, 2002: Changed the representation of structure and +unions to distinguish between undefined structures and those that are defined +to be empty (allowed on gcc). The sizeof operator is undefined for the former +and returns 0 for the latter. +
  • August 22, 2002: Apply a patch from Richard H. Y. to support +FreeBSD installations. Thanks, Richard! +
  • August 12, 2002: Fixed a bug in the translation of wide-character +strings. Now this translation matches that of the underlying compiler. Changed +the implementation of the compiler dependencies. +
  • May 25, 2002: Added interpreted constructors and destructors. +
  • May 17, 2002: Changed the representation of functions to move the +“inline” information to the varinfo. This way we can print the “inline” +even in declarations which is what gcc does. +
  • May 15, 2002: Changed the visitor for initializers to make two +tail-recursive passes (the second is a List.rev and only done if one of +the initializers change). This prevents Stack_Overflow for large +initializers. Also improved the processing of initializers when converting to +CIL. +
  • May 15, 2002: Changed the front-end to allow the use of MSVC +mode even on machines that do not have MSVC. The machine-dependent parameters +for GCC will be used in that case. +
  • May 11, 2002: Changed the representation of formals in function +types. Now the function type is purely functional. +
  • May 4, 2002: Added the function +Cil.visitCilFileSameGlobals and changed Cil.visitCilFile to be +tail recursive. This prevents stack overflow on huge files. +
  • February 28, 2002: Changed the significance of the +CompoundInit in Cil.init to allow for missing initializers at the +end of an array initializer. Added the API function +Cil.foldLeftCompoundAll. +
+ + + +
This document was translated from LATEX by +HEVEA.
+ diff --git a/cil/doc/cil.version.tex b/cil/doc/cil.version.tex new file mode 100644 index 0000000..c584859 --- /dev/null +++ b/cil/doc/cil.version.tex @@ -0,0 +1,2 @@ +\def\cilversion{1.3.5} +\def\ccuredversion{@CCURED_VERSION@} diff --git a/cil/doc/cil001.html b/cil/doc/cil001.html new file mode 100644 index 0000000..5edc5da --- /dev/null +++ b/cil/doc/cil001.html @@ -0,0 +1,134 @@ + + + + + + + + + + + + + +Introduction + + + +Up +Next +
+ +

1  Introduction

+New: CIL now has a Source Forge page: + http://sourceforge.net/projects/cil.
+
+CIL (C Intermediate Language) is a high-level representation +along with a set of tools that permit easy analysis and source-to-source +transformation of C programs.
+
+CIL is both lower-level than abstract-syntax trees, by clarifying ambiguous +constructs and removing redundant ones, and also higher-level than typical +intermediate languages designed for compilation, by maintaining types and a +close relationship with the source program. The main advantage of CIL is that +it compiles all valid C programs into a few core constructs with a very clean +semantics. Also CIL has a syntax-directed type system that makes it easy to +analyze and manipulate C programs. Furthermore, the CIL front-end is able to +process not only ANSI-C programs but also those using Microsoft C or GNU C +extensions. If you do not use CIL and want instead to use just a C parser and +analyze programs expressed as abstract-syntax trees then your analysis will +have to handle a lot of ugly corners of the language (let alone the fact that +parsing C itself is not a trivial task). See Section 16 for some +examples of such extreme programs that CIL simplifies for you.
+
+In essence, CIL is a highly-structured, “clean” subset of C. CIL features a +reduced number of syntactic and conceptual forms. For example, all looping +constructs are reduced to a single form, all function bodies are given +explicit return statements, syntactic sugar like "->" is +eliminated and function arguments with array types become pointers. (For an +extensive list of how CIL simplifies C programs, see Section 4.) +This reduces the number of cases that must be considered when manipulating a C +program. CIL also separates type declarations from code and flattens scopes +within function bodies. This structures the program in a manner more amenable +to rapid analysis and transformation. CIL computes the types of all program +expressions, and makes all type promotions and casts explicit. CIL supports +all GCC and MSVC extensions except for nested functions and complex numbers. +Finally, CIL organizes C's imperative features into expressions, instructions +and statements based on the presence and absence of side-effects and +control-flow. Every statement can be annotated with successor and predecessor +information. Thus CIL provides an integrated program representation that can +be used with routines that require an AST (e.g. type-based analyses and +pretty-printers), as well as with routines that require a CFG (e.g., dataflow +analyses). CIL also supports even lower-level representations (e.g., +three-address code), see Section 8.
+
+CIL comes accompanied by a number of Perl scripts that perform generally +useful operations on code: +
  • +A driver which behaves as either the gcc or +Microsoft VC compiler and can invoke the preprocessor followed by the CIL +application. The advantage of this script is that you can easily use CIL and +the analyses written for CIL with existing make files. +
  • A whole-program merger that you can use as a +replacement for your compiler and it learns all the files you compile when you +make a project and merges all of the preprocessed source files into a single +one. This makes it easy to do whole-program analysis. +
  • A patcher makes it easy to create modified +copies of the system include files. The CIL driver can then be told to use +these patched copies instead of the standard ones. +
+CIL has been tested very extensively. It is able to process the SPECINT95 +benchmarks, the Linux kernel, GIMP and other open-source projects. All of +these programs are compiled to the simple CIL and then passed to gcc and +they still run! We consider the compilation of Linux a major feat especially +since Linux contains many of the ugly GCC extensions (see Section 16.2). +This adds to about 1,000,000 lines of code that we tested it on. It is also +able to process the few Microsoft NT device drivers that we have had access +to. CIL was tested against GCC's c-torture testsuite and (except for the tests +involving complex numbers and inner functions, which CIL does not currently +implement) CIL passes most of the tests. Specifically CIL fails 23 tests out +of the 904 c-torture tests that it should pass. GCC itself fails 19 tests. A +total of 1400 regression test cases are run automatically on each change to +the CIL sources.
+
+CIL is relatively independent on the underlying machine and compiler. When +you build it CIL will configure itself according to the underlying compiler. +However, CIL has only been tested on Intel x86 using the gcc compiler on Linux +and cygwin and using the MS Visual C compiler. (See below for specific +versions of these compilers that we have used CIL for.)
+
+The largest application we have used CIL for is +CCured, a compiler that compiles C code into +type-safe code by analyzing your pointer usage and inserting runtime checks in +the places that cannot be guaranteed statically to be type safe.
+
+You can also use CIL to “compile” code that uses GCC extensions (e.g. the +Linux kernel) into standard C code.
+
+CIL also comes accompanies by a growing library of extensions (see +Section 8). You can use these for your projects or as examples of +using CIL.
+
+PDF versions of this manual and the +CIL API are available. However, we recommend the +HTML versions because the postprocessed code examples are easier to +view.
+
+If you use CIL in your project, we would appreciate letting us know. If you +want to cite CIL in your research writings, please refer to the paper “CIL: +Intermediate Language and Tools for Analysis and Transformation of C +Programs” by George C. Necula, Scott McPeak, S.P. Rahul and Westley Weimer, +in “Proceedings of Conference on Compilier Construction”, 2002.
+
+
+Up +Next + + diff --git a/cil/doc/cil002.html b/cil/doc/cil002.html new file mode 100644 index 0000000..e575ce3 --- /dev/null +++ b/cil/doc/cil002.html @@ -0,0 +1,98 @@ + + + + + + + + + + + + + +Installation + + + +Previous +Up +Next +
+ +

2  Installation

+You will need OCaml release 3.08 or higher to build CIL. CIL has been tested +on Linux and on Windows (where it can behave at either Microsoft Visual C or +gcc).
+
+If you want to use CIL on Windows then you must get a complete installation +of cygwin and the source-code OCaml distribution and compile it yourself +using the cygwin tools (as opposed to getting the Win32 native-code version of +OCaml). If you have not done this before then take a look +here. (Don't need to worry about cvs and +ssh unless you will need to use the master CVS repository for CIL.) +
  1. +Download the CIL distribution (latest version is +distrib/cil-1.3.5.tar.gz). See the Section 20 for recent changes to the CIL distribution. +
  2. Unzip and untar the source distribution. This will create a directory + called cil whose structure is explained below.
    +tar xvfz cil-1.3.5.tar.gz +
  3. Enter the cil directory and run the configure script and then + GNU make to build the distribution. If you are on Windows, at least the + configure step must be run from within bash.
    +    cd cil
    +    ./configure
    +    make
    +    make quicktest
    +
  4. You should now find cilly.asm.exe in a +subdirectory of obj. The name of the subdirectory is either x86_WIN32 +if you are using cygwin on Windows or x86_LINUX if you are using +Linux (although you should be using instead the Perl wrapper bin/cilly). +Note that we do not have an install make target and you should use Cil +from the development directory. +
  5. If you decide to use CIL, please +send us a note. This will help recharge +our batteries after more than a year of development. And of course, do send us +your bug reports as well.
+The configure script tries to find appropriate defaults for your system. +You can control its actions by passing the following arguments: +
  • +CC=foo Specifies the path for the gcc executable. By default +whichever version is in the PATH is used. If CC specifies the Microsoft +cl compiler, then that compiler will be set as the default one. Otherwise, +the gcc compiler will be the default. +
+CIL requires an underlying C compiler and preprocessor. CIL depends on the +underlying compiler and machine for the sizes and alignment of types.The +installation procedure for CIL queries the underlying compiler for +architecture and compiler dependent configuration parameters, such as the size +of a pointer or the particular alignment rules for structure fields. (This +means, of course, that you should re-run ./configure when you move CIL to +another machine.)
+
+We have tested CIL on the following compilers: +
  • +On Windows, cl compiler version 12.00.8168 (MSVC 6), + 13.00.9466 (MSVC .Net), and 13.10.3077 (MSVC .Net 2003). Run cl + with no arguments to get the compiler version. +
  • On Windows, using cygwin and gcc version 2.95.3, 3.0, + 3.2, 3.3, and 3.4. +
  • On Linux, using gcc version 2.95.3, 3.0, 3.2, 3.3, and 4.0. +
+Others have successfully used CIL with Mac OS X (on both PowerPC and +x86), Solaris, and *BSD. If you make any changes to the build +system in order to run CIL on your platform, please send us a patch.
+
+
+Previous +Up +Next + + diff --git a/cil/doc/cil003.html b/cil/doc/cil003.html new file mode 100644 index 0000000..4b885f3 --- /dev/null +++ b/cil/doc/cil003.html @@ -0,0 +1,187 @@ + + + + + + + + + + + + + +Distribution Contents + + + +Previous +Up +Next +
+ +

3  Distribution Contents

+The file distrib/cil-1.3.5.tar.gz +contains the complete source CIL distribution, +consisting of the following files:
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
FilenameDescription
Makefile.inconfigure source for the + Makefile that builds CIL
configureThe configure script
configure.inThe autoconf source for configure
config.guess, config.sub, install-shstuff required by + configure
 
doc/HTML documentation of the CIL API
obj/Directory that will contain the compiled + CIL modules and executables
bin/cilly.inThe configure source for a Perl script + that can be invoked with the + same arguments as either gcc or + Microsoft Visual C and will convert the + program to CIL, perform some simple + transformations, emit it and compile it as + usual.
lib/CompilerStub.pmA Perl class that can be used to write code + that impersonates a compiler. cilly + uses it.
lib/Merger.pmA subclass of CompilerStub.pm that can + be used to merge source files into a single + source file.cilly + uses it.
bin/patcher.inA Perl script that applies specified patches + to standard include files.
 
src/check.ml,mliChecks the well-formedness of a CIL file
src/cil.ml,mliDefinition of CIL abstract syntax and + utilities for manipulating it
src/clist.ml,mliUtilities for efficiently managing lists + that need to be concatenated often
src/errormsg.ml,mliUtilities for error reporting
src/ext/heapify.mlA CIL transformation that moves array local + variables from the stack to the heap
src/ext/logcalls.ml,mliA CIL transformation that logs every + function call
src/ext/sfi.mlA CIL transformation that can log every + memory read and write
src/frontc/clexer.mllThe lexer
src/frontc/cparser.mlyThe parser
src/frontc/cabs.mlThe abstract syntax
src/frontc/cprint.mlThe pretty printer for CABS
src/frontc/cabs2cil.mlThe elaborator to CIL
src/main.mlThe cilly application
src/pretty.ml,mliUtilities for pretty printing
src/rmtmps.ml,mliA CIL tranformation that removes unused + types, variables and inlined functions
src/stats.ml,mliUtilities for maintaining timing statistics
src/testcil.mlA random test of CIL (against the resident + C compiler)
src/trace.ml,mliUtilities useful for printing debugging + information
 
ocamlutil/Miscellaneous libraries that are not + specific to CIL.
ocamlutil/Makefile.ocamlA file that is included by Makefile
ocamlutil/Makefile.ocaml.buildA file that is included by Makefile
ocamlutil/perfcount.cC code that links with src/stats.ml + and reads Intel performance + counters.
 
obj/@ARCHOS@/feature_config.mlFile generated by the Makefile + describing which extra “features” + to compile. See Section 5
obj/@ARCHOS@/machdep.mlFile generated by the Makefile containing + information about your architecture, + such as the size of a pointer
src/machdep.cC program that generates + machdep.ml files

+
+Previous +Up +Next + + diff --git a/cil/doc/cil004.html b/cil/doc/cil004.html new file mode 100644 index 0000000..16fde39 --- /dev/null +++ b/cil/doc/cil004.html @@ -0,0 +1,350 @@ + + + + + + + + + + + + + +Compiling C to CIL + + + +Previous +Up +Next +
+ +

4  Compiling C to CIL

+In this section we try to describe a few of the many transformations that are +applied to a C program to convert it to CIL. The module that implements this +conversion is about 5000 lines of OCaml code. In contrast a simple program +transformation that instruments all functions to keep a shadow stack of the +true return address (thus preventing stack smashing) is only 70 lines of code. +This example shows that the analysis is so much simpler because it has to +handle only a few simple C constructs and also because it can leverage on CIL +infrastructure such as visitors and pretty-printers.
+
+In no particular order these are a few of the most significant ways in which +C programs are compiled into CIL: +
  1. +CIL will eliminate all declarations for unused entities. This means that +just because your hello world program includes stdio.h it does not mean +that your analysis has to handle all the ugly stuff from stdio.h.
    +
    +
  2. Type specifiers are interpreted and normalized: +
    
+int long signed x;
+signed long extern x;
+long static int long y;
+
+// Some code that uses these declaration, so that CIL does not remove them
+int main() { return x + y; }
+
    +See the CIL output for this +code fragment
    +
    +
  3. Anonymous structure and union declarations are given a name. +
    
+ struct { int x; } s;
+
    +See the CIL output for this +code fragment
    +
    +
  4. Nested structure tag definitions are pulled apart. This means that all +structure tag definitions can be found by a simple scan of the globals. +
    
+struct foo {
+   struct bar {
+      union baz { 
+          int x1; 
+          double x2;
+      } u1;
+      int y;
+   } s1;
+   int z;
+} f;
+
    +See the CIL output for this +code fragment
    +
    +
  5. All structure, union, enumeration definitions and the type definitions +from inners scopes are moved to global scope (with appropriate renaming). This +facilitates moving around of the references to these entities. +
    
+int main() {
+  struct foo { 
+        int x; } foo; 
+  {
+     struct foo { 
+        double d;
+     };
+     return foo.x;
+  }      
+}
+
    +See the CIL output for this +code fragment
    +
    +
  6. Prototypes are added for those functions that are called before being +defined. Furthermore, if a prototype exists but does not specify the type of +parameters that is fixed. But CIL will not be able to add prototypes for those +functions that are neither declared nor defined (but are used!). +
    
+  int f();  // Prototype without arguments
+  int f(double x) {
+      return g(x);
+  }
+  int g(double x) {
+     return x;
+  } 
+
    +See the CIL output for this +code fragment
    +
    +
  7. Array lengths are computed based on the initializers or by constant +folding. +
    
+  int a1[] = {1,2,3};
+  int a2[sizeof(int) >= 4 ? 8 : 16];
+
    +See the CIL output for this +code fragment
    +
    +
  8. Enumeration tags are computed using constant folding: +
    
+int main() {
+  enum { 
+     FIVE = 5, 
+     SIX, SEVEN, 
+     FOUR = FIVE - 1, 
+     EIGHT = sizeof(double)
+  } x = FIVE;
+ return x;
+}
+
+
    +See the CIL output for this +code fragment
    +
    +
  9. Initializers are normalized to include specific initialization for the +missing elements: +
    
+  int a1[5] = {1,2,3};
+  struct foo { int x, y; } s1 = { 4 };
+
    +See the CIL output for this +code fragment
    +
    +
  10. Initializer designators are interpreted and eliminated. Subobjects are +properly marked with braces. CIL implements +the whole ISO C99 specification for initializer (neither GCC nor MSVC do) and +a few GCC extensions. +
    
+  struct foo { 
+     int x, y; 
+     int a[5];
+     struct inner {
+        int z;
+     } inner;
+  } s = { 0, .inner.z = 3, .a[1 ... 2] = 5, 4, y : 8 };
+
    +See the CIL output for this +code fragment
    +
    +
  11. String initializers for arrays of characters are processed +
    
+char foo[] = "foo plus bar";
+
    +See the CIL output for this +code fragment
    +
    +
  12. String constants are concatenated +
    
+char *foo = "foo " " plus " " bar ";
+
    +See the CIL output for this +code fragment
    +
    +
  13. Initializers for local variables are turned into assignments. This is in +order to separate completely the declarative part of a function body from the +statements. This has the unfortunate effect that we have to drop the const +qualifier from local variables ! +
    
+  int x = 5; 
+  struct foo { int f1, f2; } a [] = {1, 2, 3, 4, 5 };
+
    +See the CIL output for this +code fragment
    +
    +
  14. Local variables in inner scopes are pulled to function scope (with +appropriate renaming). Local scopes thus disappear. This makes it easy to find +and operate on all local variables in a function. +
    
+  int x = 5; 
+  int main() {
+    int x = 6;
+    { 
+      int x = 7;
+      return x;
+    }
+    return x;
+  } 
+
    +See the CIL output for this +code fragment
    +
    +
  15. Global declarations in local scopes are moved to global scope: +
    
+  int x = 5; 
+  int main() {
+    int x = 6;
+    { 
+      static int x = 7;
+      return x;
+    }
+    return x;
+  } 
+
    +See the CIL output for this +code fragment
    +
    +
  16. Return statements are added for functions that are missing them. If the +return type is not a base type then a return without a value is added. +The guaranteed presence of return statements makes it easy to implement a +transformation that inserts some code to be executed immediately before +returning from a function. +
    
+  int foo() {
+    int x = 5;
+  } 
+
    +See the CIL output for this +code fragment
    +
    +
  17. One of the most significant transformations is that expressions that +contain side-effects are separated into statements. +
    
+   int x, f(int);
+   return (x ++ + f(x));
+
    +See the CIL output for this +code fragment
    +
    +Internally, the x ++ statement is turned into an assignment which the +pretty-printer prints like the original. CIL has only three forms of basic +statements: assignments, function calls and inline assembly.
    +
    +
  18. Shortcut evaluation of boolean expressions and the ?: operator are +compiled into explicit conditionals: +
    
+  int x;
+  int y = x ? 2 : 4;
+  int z = x || y;
+  // Here we duplicate the return statement
+  if(x && y) { return 0; } else { return 1; }
+  // To avoid excessive duplication, CIL uses goto's for 
+  // statement that have more than 5 instructions
+  if(x && y || z) { x ++; y ++; z ++; x ++; y ++; return z; }
+
    +See the CIL output for this +code fragment
    +
    +
  19. GCC's conditional expression with missing operands are also compiled +into conditionals: +
    
+  int f();;
+  return f() ? : 4;
+
    +See the CIL output for this +code fragment
    +
    +
  20. All forms of loops (while, for and do) are compiled +internally as a single while(1) looping construct with explicit break +statement for termination. For simple while loops the pretty printer is +able to print back the original: +
    
+   int x, y;
+   for(int i = 0; i<5; i++) {
+      if(i == 5) continue;
+      if(i == 4) break;
+      i += 2;
+   } 
+   while(x < 5) {
+     if(x == 3) continue;
+     x ++;
+   }
+
    +See the CIL output for this +code fragment
    +
    +
  21. GCC's block expressions are compiled away. (That's right there is an +infinite loop in this code.) +
    
+   int x = 5, y = x;
+   int z = ({ x++; L: y -= x; y;});
+   return ({ goto L; 0; });
+
    +See the CIL output for this +code fragment
    +
    +
  22. CIL contains support for both MSVC and GCC inline assembly (both in one +internal construct)
    +
    +
  23. CIL compiles away the GCC extension that allows many kinds of constructs +to be used as lvalues: +
    
+   int x, y, z;
+   return &(x ? y : z) - & (x ++, x);
+
    +See the CIL output for this +code fragment
    +
    +
  24. All types are computed and explicit casts are inserted for all +promotions and conversions that a compiler must insert:
    +
    +
  25. CIL will turn old-style function definition (without prototype) into +new-style definitions. This will make the compiler less forgiving when +checking function calls, and will catch for example cases when a function is +called with too few arguments. This happens in old-style code for the purpose +of implementing variable argument functions.
    +
    +
  26. Since CIL sees the source after preprocessing the code after CIL does +not contain the comments and the preprocessing directives.
    +
    +
  27. CIL will remove from the source file those type declarations, local +variables and inline functions that are not used in the file. This means that +your analysis does not have to see all the ugly stuff that comes from the +header files: +
    
+#include <stdio.h>
+
+typedef int unused_type;
+
+static char unused_static (void) { return 0; }
+
+int main() {
+  int unused_local;
+  printf("Hello world\n"); // Only printf will be kept from stdio.h     
+}
+
    +See the CIL output for this +code fragment
+
+Previous +Up +Next + + diff --git a/cil/doc/cil006.html b/cil/doc/cil006.html new file mode 100644 index 0000000..8fc3194 --- /dev/null +++ b/cil/doc/cil006.html @@ -0,0 +1,627 @@ + + + + + + + + + + + + + +CIL API Documentation + + + +Previous +Up +Next +
+ +

6  CIL API Documentation

+The CIL API is documented in the file src/cil.mli. We also have an +online documentation extracted from cil.mli. We +index below the main types that are used to represent C programs in CIL: + + +

6.1  Using the visitor

+One of the most useful tools exported by the CIL API is an implementation of +the visitor pattern for CIL programs. The visiting engine scans depth-first +the structure of a CIL program and at each node is queries a user-provided +visitor structure whether it should do one of the following operations: +
  • +Ignore this node and all its descendants +
  • Descend into all of the children and when done rebuild the node if any +of the children have changed. +
  • Replace the subtree rooted at the node with another tree. +
  • Replace the subtree with another tree, then descend into the children +and rebuild the node if necessary and then invoke a user-specified function. +
  • In addition to all of the above actions then visitor can specify that +some instructions should be queued to be inserted before the current +instruction or statement being visited. +
+By writing visitors you can customize the program traversal and +transformation. One major limitation of the visiting engine is that it does +not propagate information from one node to another. Each visitor must use its +own private data to achieve this effect if necessary.
+
+Each visitor is an object that is an instance of a class of type Cil.cilVisitor.. +The most convenient way to obtain such classes is to specialize the +Cil.nopCilVisitor.class (which just traverses the tree doing +nothing). Any given specialization typically overrides only a few of the +methods. Take a look for example at the visitor defined in the module +logwrites.ml. Another, more elaborate example of a visitor is the +[copyFunctionVisitor] defined in cil.ml.
+
+Once you have defined a visitor you can invoke it with one of the functions: + +Some transformations may want to use visitors to insert additional +instructions before statements and instructions. To do so, pass a list of +instructions to the Cil.queueInstr method of the specialized +object. The instructions will automatically be inserted before that +instruction in the transformed code. The Cil.unqueueInstr method +should not normally be called by the user.
+
+ +

6.2  Interpreted Constructors and Deconstructors

+Interpreted constructors and deconstructors are a facility for constructing +and deconstructing CIL constructs using a pattern with holes that can be +filled with a variety of kinds of elements. The pattern is a string that uses +the C syntax to represent C language elements. For example, the following +code: +

+Formatcil.cType "void * const (*)(int x)"
+
+is an alternative way to construct the internal representation of the type of pointer to function +with an integer argument and a void * const as result: +

+TPtr(TFun(TVoid [Attr("const", [])],
+          [ ("x", TInt(IInt, []), []) ], false, []), [])
+
+The advantage of the interpreted constructors is that you can use familiar C +syntax to construct CIL abstract-syntax trees.
+
+You can construct this way types, lvalues, expressions, instructions and +statements. The pattern string can also contain a number of placeholders that +are replaced during construction with CIL items passed as additional argument +to the construction function. For example, the %e:id placeholder means +that the argument labeled “id” (expected to be of form Fe exp) will +supply the expression to replace the placeholder. For example, the following +code constructs an increment instruction at location loc: +

+Formatcil.cInstr "%v:x = %v:x + %e:something"
+        loc
+        [ ("something", Fe some_exp);
+          ("x", Fv some_varinfo) ]
+
+An alternative way to construct the same CIL instruction is: +

+Set((Var some_varinfo, NoOffset),
+    BinOp(PlusA, Lval (Var some_varinfo, NoOffset),
+          some_exp, intType), 
+    loc)
+
+See Cil.formatArg for a definition of the placeholders that are +understood.
+
+A dual feature is the interpreted deconstructors. This can be used to test +whether a CIL construct has a certain form: +

+Formatcil.dType "void * const (*)(int x)" t
+
+will test whether the actual argument t is indeed a function pointer of +the required type. If it is then the result is Some [] otherwise it is +None. Furthermore, for the purpose of the interpreted deconstructors +placeholders in patterns match anything of the right type. For example, +

+Formatcil.dType "void * (*)(%F:t)" t
+
+will match any function pointer type, independent of the type and number of +the formals. If the match succeeds the result is Some [ FF forms ] where +forms is a list of names and types of the formals. Note that each member +in the resulting list corresponds positionally to a placeholder in the +pattern.
+
+The interpreted constructors and deconstructors do not support the complete C +syntax, but only a substantial fragment chosen to simplify the parsing. The +following is the syntax that is supported: +
+Expressions:
+  E ::= %e:ID | %d:ID | %g:ID | n | L | ( E ) | Unop E | E Binop E 
+        | sizeof E | sizeof ( T ) | alignof E  | alignof ( T ) 
+        | & L | ( T ) E 
+
+Unary operators:
+  Unop ::= + | - | ~ | %u:ID
+
+Binary operators:
+  Binop ::= + | - | * | / | << | >> | & | ``|'' | ^ 
+          | == | != | < | > | <= | >= | %b:ID
+
+Lvalues:
+  L ::= %l:ID | %v:ID Offset | * E | (* E) Offset | E -> ident Offset 
+
+Offsets:
+  Offset ::= empty | %o:ID | . ident Offset | [ E ] Offset
+
+Types:
+  T ::= Type_spec Attrs Decl
+
+Type specifiers:
+  Type_spec ::= void | char | unsigned char | short | unsigned short
+            | int | unsigned int | long | unsigned long | %k:ID | float 
+            | double | struct %c:ID | union %c:ID 
+
+
+Declarators:
+  Decl ::= * Attrs Decl | Direct_decl
+
+
+Direct declarators:
+  Direct_decl ::= empty | ident | ( Attrs Decl ) 
+                 | Direct_decl [ Exp_opt ]
+                 | ( Attrs Decl )( Parameters )
+
+Optional expressions
+  Exp_opt ::= empty | E | %eo:ID
+
+Formal parameters
+  Parameters ::= empty | ... | %va:ID | %f:ID | T | T , Parameters
+
+List of attributes
+  Attrs ::= empty | %A:ID | Attrib Attrs
+
+Attributes
+  Attrib ::= const | restrict | volatile | __attribute__ ( ( GAttr ) )
+
+GCC Attributes
+  GAttr ::= ident | ident ( AttrArg_List )
+
+Lists of GCC Attribute arguments:
+  AttrArg_List ::= AttrArg | %P:ID | AttrArg , AttrArg_List
+
+GCC Attribute arguments  
+  AttrArg ::= %p:ID | ident | ident ( AttrArg_List )
+
+Instructions
+  Instr ::= %i:ID ; | L = E ; | L Binop= E | Callres L ( Args )
+
+Actual arguments
+   Args ::= empty | %E:ID | E | E , Args
+
+Call destination
+   Callres ::= empty | L = | %lo:ID
+
+Statements
+  Stmt ::= %s:ID | if ( E ) then Stmt ; | if ( E ) then Stmt else Stmt ;
+       | return Exp_opt | break ; | continue ; | { Stmt_list } 
+       | while (E ) Stmt | Instr_list 
+
+Lists of statements
+   Stmt_list ::= empty | %S:ID | Stmt Stmt_list  
+                | Type_spec Attrs Decl ; Stmt_list
+                | Type_spec Attrs Decl = E ; Stmt_list
+                | Type_spec Attrs Decl = L (Args) ; Stmt_list
+
+List of instructions
+   Instr_list ::= Instr | %I:ID | Instr Instr_list
+
+Notes regarding the syntax: +
  • +In the grammar description above non-terminals are written with +uppercase initial
    +
    +
  • All of the patterns consist of the % character followed by one or +two letters, followed by “:” and an indentifier. For each such +pattern there is a corresponding constructor of the Cil.formatArg +type, whose name is the letter 'F' followed by the same one or two letters as +in the pattern. That constructor is used by the user code to pass a +Cil.formatArg actual argument to the interpreted constructor and by +the interpreted deconstructor to return what was matched for a pattern.
    +
    +
  • If the pattern name is uppercase, it designates a list of the elements +designated by the corresponding lowercase pattern. E.g. %E designated lists +of expressions (as in the actual arguments of a call).
    +
    +
  • The two-letter patterns whose second letter is “o” designate an +optional element. E.g. %eo designates an optional expression (as in the +length of an array).
    +
    +
  • Unlike in calls to printf, the pattern %g is used for strings.
    +
    +
  • The usual precedence and associativity rules as in C apply
    +
    +
  • The pattern string can contain newlines and comments, using both the +/* ... */ style as well as the // one.
    +
    +
  • When matching a “cast” pattern of the form ( T ) E, the +deconstructor will match even expressions that do not have the actual cast but +in that case the type is matched against the type of the expression. E.g. the +patters "(int)%e" will match any expression of type int whether it +has an explicit cast or not.
    +
    +
  • The %k pattern is used to construct and deconstruct an integer type of +any kind.
    +
    +
  • Notice that the syntax of types and declaration are the same (in order +to simplify the parser). This means that technically you can write a whole +declaration instead of a type in the cast. In this case the name that you +declare is ignored.
    +
    +
  • In lists of formal parameters and lists of attributes, an empty list in +the pattern matches any formal parameters or attributes.
    +
    +
  • When matching types, uses of named types are unrolled to expose a real +type before matching.
    +
    +
  • The order of the attributes is ignored during matching. The the pattern +for a list of attributes contains %A then the resulting formatArg will be +bound to all attributes in the list. For example, the pattern "const +%A" matches any list of attributes that contains const and binds the +corresponding placeholder to the entire list of attributes, including +const.
    +
    +
  • All instruction-patterns must be terminated by semicolon
    +
    +
  • The autoincrement and autodecrement instructions are not supported. Also +not supported are complex expressions, the && and || shortcut +operators, and a number of other more complex instructions or statements. In +general, the patterns support only constructs that can be represented directly +in CIL.
    +
    +
  • The pattern argument identifiers are not used during deconstruction. +Instead, the result contains a sequence of values in the same order as the +appearance of pattern arguments in the pattern.
    +
    +
  • You can mix statements with declarations. For each declaration a new + temporary will be constructed (using a function you provive). You can then + refer to that temporary by name in the rest of the pattern.
    +
    +
  • The %v: pattern specifier is optional. +
+The following function are defined in the Formatcil module for +constructing and deconstructing: + +Below is an example using interpreted constructors. This example generates +the CIL representation of code that scans an array backwards and initializes +every even-index element with an expression: +

+Formatcil.cStmts
+  loc
+  "int idx = sizeof(array) / sizeof(array[0]) - 1;
+   while(idx >= 0) {
+     // Some statements to be run for all the elements of the array
+     %S:init
+     if(! (idx & 1)) 
+       array[idx] = %e:init_even;
+     /* Do not forget to decrement the index variable */
+     idx = idx - 1;
+   }"
+  (fun n t -> makeTempVar myfunc ~name:n t)
+  [ ("array", Fv myarray); 
+    ("init", FS [stmt1; stmt2; stmt3]);
+    ("init_even", Fe init_expr_for_even_elements) ]
+
+To write the same CIL statement directly in CIL would take much more effort. +Note that the pattern is parsed only once and the result (a function that +takes the arguments and constructs the statement) is memoized.
+
+ +

6.2.1  Performance considerations for interpreted constructors

+Parsing the patterns is done with a LALR parser and it takes some time. To +improve performance the constructors and deconstructors memoize the parsed +patterns and will only compile a pattern once. Also all construction and +deconstruction functions can be applied partially to the pattern string to +produce a function that can be later used directly to construct or +deconstruct. This function appears to be about two times slower than if the +construction is done using the CIL constructors (without memoization the +process would be one order of magnitude slower.) However, the convenience of +interpreted constructor might make them a viable choice in many situations +when performance is not paramount (e.g. prototyping).
+
+ +

6.3  Printing and Debugging support

+The Modules Pretty and Errormsg contain respectively +utilities for pretty printing and reporting errors and provide a convenient +printf-like interface.
+
+Additionally, CIL defines for each major type a pretty-printing function that +you can use in conjunction with the Pretty interface. The +following are some of the pretty-printing functions: + +You can even customize the pretty-printer by creating instances of +Cil.cilPrinter.. Typically such an instance extends +Cil.defaultCilPrinter. Once you have a customized pretty-printer you +can use the following printing functions: + +CIL has certain internal consistency invariants. For example, all references +to a global variable must point to the same varinfo structure. This +ensures that one can rename the variable by changing the name in the +varinfo. These constraints are mentioned in the API documentation. There +is also a consistency checker in file src/check.ml. If you suspect that +your transformation is breaking these constraints then you can pass the +--check option to cilly and this will ensure that the consistency checker +is run after each transformation.
+
+ +

6.4  Attributes

+In CIL you can attach attributes to types and to names (variables, functions +and fields). Attributes are represented using the type Cil.attribute. +An attribute consists of a name and a number of arguments (represented using +the type Cil.attrparam). Almost any expression can be used as an +attribute argument. Attributes are stored in lists sorted by the name of the +attribute. To maintain list ordering, use the functions +Cil.typeAttrs to retrieve the attributes of a type and the functions +Cil.addAttribute and Cil.addAttributes to add attributes. +Alternatively you can use Cil.typeAddAttributes to add an attribute to +a type (and return the new type).
+
+GCC already has extensive support for attributes, and CIL extends this +support to user-defined attributes. A GCC attribute has the syntax: +
+ gccattribute ::= __attribute__((attribute))    (Note the double parentheses)
+
+ Since GCC and MSVC both support various flavors of each attribute (with or +without leading or trailing _) we first strip ALL leading and trailing _ +from the attribute name (but not the identified in [ACons] parameters in +Cil.attrparam). When we print attributes, for GCC we add two leading +and two trailing _; for MSVC we add just two leading _.
+
+There is support in CIL so that you can control the printing of attributes +(see Cil.setCustomPrintAttribute and +Cil.setCustomPrintAttributeScope). This custom-printing support is now +used to print the "const" qualifier as "const" and not as +"__attribute__((const))".
+
+The attributes are specified in declarations. This is unfortunate since the C +syntax for declarations is already quite complicated and after writing the +parser and elaborator for declarations I am convinced that few C programmers +understand it completely. Anyway, this seems to be the easiest way to support +attributes.
+
+Name attributes must be specified at the very end of the declaration, just +before the = for the initializer or before the , the separates a +declaration in a group of declarations or just before the ; that +terminates the declaration. A name attribute for a function being defined can +be specified just before the brace that starts the function body.
+
+For example (in the following examples A1,...,An are type attributes +and N is a name attribute (each of these uses the __attribute__ syntax): +

+ int x N;
+ int x N, * y N = 0, z[] N;
+ extern void exit() N;
+ int fact(int x) N { ... }
+
+Type attributes can be specified along with the type using the following + rules: +
  1. + The type attributes for a base type (int, float, named type, reference + to struct or union or enum) must be specified immediately following the + type (actually it is Ok to mix attributes with the specification of the + type, in between unsigned and int for example).
    +
    +For example: +
    
+  int A1 x N;  /* A1 applies to the type int. An example is an attribute
+                   "even" restricting the type int to even values. */
+  struct foo A1 A2 x; // Both A1 and A2 apply to the struct foo type
+

    +
    +
  2. The type attributes for a pointer type must be specified immediately + after the * symbol. +
    
+ /* A pointer (A1) to an int (A2) */
+ int A2 * A1 x;
+ /* A pointer (A1) to a pointer (A2) to a float (A3) */
+ float A3 * A2 * A1 x;
+
    +Note: The attributes for base types and for pointer types are a strict + extension of the ANSI C type qualifiers (const, volatile and restrict). In + fact CIL treats these qualifiers as attributes.
    +
    +
  3. The attributes for a function type or for an array type can be + specified using parenthesized declarators.
    +
    +For example: +
    
+   /* A function (A1) from int (A2) to float (A3) */
+   float A3 (A1 f)(int A2);
+
+   /* A pointer (A1) to a function (A2) that returns an int (A3) */
+   int A3 (A2 * A1 pfun)(void);
+
+   /* An array (A1) of int (A2) */
+   int A2 (A1 x0)[]
+
+   /* Array (A1) of pointers (A2) to functions (A3) that take an int (A4) and 
+    * return a pointer (A5) to int (A6)  */
+   int A6 * A5 (A3 * A2 (A1 x1)[5])(int A4);
+
+
+   /* A function (A4) that takes a float (A5) and returns a pointer (A6) to an 
+    * int (A7) */
+   extern int A7 * A6 (A4 x2)(float A5 x);
+
+   /* A function (A1) that takes a int (A2) and that returns a pointer (A3) to 
+    * a function (A4) that takes a float (A5) and returns a pointer (A6) to an 
+    * int (A7) */
+   int A7 * A6 (A4 * A3 (A1 x3)(int A2 x))(float A5) {
+      return & x2;
+   }
+
+Note: ANSI C does not allow the specification of type qualifiers for function +and array types, although it allows for the parenthesized declarator. With +just a bit of thought (looking at the first few examples above) I hope that +the placement of attributes for function and array types will seem intuitive.
+
+This extension is not without problems however. If you want to refer just to +a type (in a cast for example) then you leave the name out. But this leads to +strange conflicts due to the parentheses that we introduce to scope the +attributes. Take for example the type of x0 from above. It should be written +as: +

+        int A2 (A1 )[]
+
+But this will lead most C parsers into deep confusion because the parentheses +around A1 will be confused for parentheses of a function designator. To push +this problem around (I don't know a solution) whenever we are about to print a +parenthesized declarator with no name but with attributes, we comment out the +attributes so you can see them (for whatever is worth) without confusing the +compiler. For example, here is how we would print the above type: +

+        int A2 /*(A1 )*/[]
+
+ +
Handling of predefined GCC attributes
+GCC already supports attributes in a lot of places in declarations. The only +place where we support attributes and GCC does not is right before the { that +starts a function body.
+
+GCC classifies its attributes in attributes for functions, for variables and +for types, although the latter category is only usable in definition of struct +or union types and is not nearly as powerful as the CIL type attributes. We +have made an effort to reclassify GCC attributes as name and type attributes +(they only apply for function types). Here is what we came up with: +
  • + GCC name attributes:
    +
    +section, constructor, destructor, unused, weak, no_instrument_function, + noreturn, alias, no_check_memory_usage, dllinport, dllexport, exception, + model
    +
    +Note: the "noreturn" attribute would be more appropriately qualified as a + function type attribute. But we classify it as a name attribute to make + it easier to support a similarly named MSVC attribute.
    +
    +
  • GCC function type attributes:
    +
    +fconst (printed as "const"), format, regparm, stdcall, + cdecl, longcall
    +
    +I was not able to completely decipher the position in which these attributes + must go. So, the CIL elaborator knows these names and applies the following + rules: +
    • + All of the name attributes that appear in the specifier part (i.e. at + the beginning) of a declaration are associated with all declared names.
      +
      +
    • All of the name attributes that appear at the end of a declarator are + associated with the particular name being declared.
      +
      +
    • More complicated is the handling of the function type attributes, since + there can be more than one function in a single declaration (a function + returning a pointer to a function). Lacking any real understanding of how + GCC handles this, I attach the function type attribute to the "nearest" + function. This means that if a pointer to a function is "nearby" the + attribute will be correctly associated with the function. In truth I pray + that nobody uses declarations as that of x3 above. +
    +
+ +
Handling of predefined MSVC attributes
+MSVC has two kinds of attributes, declaration modifiers to be printed before + the storage specifier using the notation "__declspec(...)" and a few + function type attributes, printed almost as our CIL function type + attributes.
+
+The following are the name attributes that are printed using + __declspec right before the storage designator of the declaration: + thread, naked, dllimport, dllexport, noreturn
+
+The following are the function type attributes supported by MSVC: + fastcall, cdecl, stdcall
+
+It is not worth going into the obscure details of where MSVC accepts these + type attributes. The parser thinks it knows these details and it pulls + these attributes from wherever they might be placed. The important thing + is that MSVC will accept if we print them according to the rules of the CIL + attributes !
+
+
+Previous +Up +Next + + diff --git a/cil/doc/cil007.html b/cil/doc/cil007.html new file mode 100644 index 0000000..7d6c023 --- /dev/null +++ b/cil/doc/cil007.html @@ -0,0 +1,279 @@ + + + + + + + + + + + + + +The CIL Driver + + + +Previous +Up +Next +
+ +

7  The CIL Driver

+We have packaged CIL as an application cilly that contains certain +example modules, such as logwrites.ml (a module +that instruments code to print the addresses of memory locations being +written). Normally, you write another module like that, add command-line +options and an invocation of your module in src/main.ml. Once you compile +CIL you will obtain the file obj/cilly.asm.exe.
+
+We wrote a driver for this executable that makes it easy to invoke your +analysis on existing C code with very little manual intervention. This driver +is bin/cilly and is quite powerful. Note that the cilly script +is configured during installation with the path where CIL resides. This means +that you can move it to any place you want.
+
+A simple use of the driver is: +
+bin/cilly --save-temps -D HAPPY_MOOD -I myincludes hello.c -o hello
+
+--save-temps tells CIL to save the resulting output files in the +current directory. Otherwise, they'll be put in /tmp and deleted +automatically. Not that this is the only CIL-specific flag in the +list – the other flags use gcc's syntax.
+
+This performs the following actions: +
  • +preprocessing using the -D and -I arguments with the resulting + file left in hello.i, +
  • the invocation of the cilly.asm application which parses hello.i + converts it to CIL and the pretty-prints it to hello.cil.c +
  • another round of preprocessing with the result placed in hello.cil.i +
  • the true compilation with the result in hello.cil.o +
  • a linking phase with the result in hello +
+Note that cilly behaves like the gcc compiler. This makes it +easy to use it with existing Makefiles: +
+make CC="bin/cilly" LD="bin/cilly"
+
+ cilly can also behave as the Microsoft Visual C compiler, if the first + argument is --mode=MSVC: +
+bin/cilly --mode=MSVC /D HAPPY_MOOD /I myincludes hello.c /Fe hello.exe
+
+ (This in turn will pass a --MSVC flag to the underlying cilly.asm + process which will make it understand the Microsoft Visual C extensions)
+
+cilly can also behave as the archiver ar, if it is passed an +argument --mode=AR. Note that only the cr mode is supported (create a +new archive and replace all files in there). Therefore the previous version of +the archive is lost.
+
+Furthermore, cilly allows you to pass some arguments on to the +underlying cilly.asm process. As a general rule all arguments that start +with -- and that cilly itself does not process, are passed on. For +example, +
+bin/cilly --dologwrites -D HAPPY_MOOD -I myincludes hello.c -o hello.exe
+
+ will produce a file hello.cil.c that prints all the memory addresses +written by the application.
+
+The most powerful feature of cilly is that it can collect all the +sources in your project, merge them into one file and then apply CIL. This +makes it a breeze to do whole-program analysis and transformation. All you +have to do is to pass the --merge flag to cilly: +
+make CC="bin/cilly --save-temps --dologwrites --merge"
+
+ You can even leave some files untouched: +
+make CC="bin/cilly --save-temps --dologwrites --merge --leavealone=foo --leavealone=bar"
+
+ This will merge all the files except those with the basename foo and +bar. Those files will be compiled as usual and then linked in at the very +end.
+
+The sequence of actions performed by cilly depends on whether merging +is turned on or not: +
  • +If merging is off +
    1. + For every file file.c to compile +
      1. + Preprocess the file with the given arguments to + produce file.i +
      2. Invoke cilly.asm to produce a file.cil.c +
      3. Preprocess to file.cil.i +
      4. Invoke the underlying compiler to produce file.cil.o +
      +
    2. Link the resulting objects +
    +
  • If merging is on +
    1. + For every file file.c to compile +
      1. + Preprocess the file with the given arguments to + produce file.i +
      2. Save the preprocessed source as file.o +
      +
    2. When linking executable hello.exe, look at every object + file that must be linked and see if it actually + contains preprocessed source. Pass all those files to a + special merging application (described in + Section 13) to produce hello.exe_comb.c +
    3. Invoke cilly.asm to produce a hello.exe_comb.cil.c +
    4. Preprocess to hello.exe_comb.cil.i +
    5. Invoke the underlying compiler to produce hello.exe_comb.cil.o +
    6. Invoke the actual linker to produce hello.exe +
    +
+Note that files that you specify with --leavealone are not merged and +never presented to CIL. They are compiled as usual and then are linked in at +the end.
+
+And a final feature of cilly is that it can substitute copies of the +system's include files: +
+make CC="bin/cilly --includedir=myinclude"
+
+ This will force the preprocessor to use the file myinclude/xxx/stdio.h +(if it exists) whenever it encounters #include <stdio.h>. The xxx is +a string that identifies the compiler version you are using. This modified +include files should be produced with the patcher script (see +Section 14).
+
+ +

7.1  cilly Options

+Among the options for the cilly you can put anything that can normally +go in the command line of the compiler that cilly is impersonating. +cilly will do its best to pass those options along to the appropriate +subprocess. In addition, the following options are supported (a complete and +up-to-date list can always be obtained by running cilly --help): +
  • +--mode=mode This must be the first argument if present. It makes +cilly behave as a given compiled. The following modes are recognized: +
    • + GNUCC - the GNU C Compiler. This is the default. +
    • MSVC - the Microsoft Visual C compiler. Of course, you should + pass only MSVC valid options in this case. +
    • AR - the archiver ar. Only the mode cr is supported and + the original version of the archive is lost. +
    +
  • --help Prints a list of the options supported. +
  • --verbose Prints lots of messages about what is going on. +
  • --stages Less than --verbose but lets you see what cilly + is doing. +
  • --merge This tells cilly to first attempt to collect into one +source file all of the sources that make your application, and then to apply +cilly.asm on the resulting source. The sequence of actions in this case is +described above and the merger itself is described in Section 13.
    +
    +
  • --leavealone=xxx. Do not merge and do not present to CIL the files +whose basename is "xxx". These files are compiled as usual and linked in at +the end. +
  • --includedir=xxx. Override the include files with those in the given +directory. The given directory is the same name that was given an an argument +to the patcher (see Section 14). In particular this means that +that directory contains subdirectories named based on the current compiler +version. The patcher creates those directories. +
  • --usecabs. Do not CIL, but instead just parse the source and print +its AST out. This should looked like the preprocessed file. This is useful +when you suspect that the conversion to CIL phase changes the meaning of the +program. +
  • --save-temps=xxx. Temporary files are preserved in the xxx + directory. For example, the output of CIL will be put in a file + named *.cil.c. +
  • --save-temps. Temporay files are preserved in the current directory. +
+ +

7.2  cilly.asm Options

+ +All of the options that start with -- and are not understood by +cilly are passed on to cilly.asm. cilly also passes along to +cilly.asm flags such as --MSVC that both need to know +about. The following options are supported:
+
+       General Options: +
  • + --version output version information and exit +
  • --verbose Print lots of random stuff. This is passed on from cilly +
  • --warnall Show all warnings. +
  • --debug=xxx turns on debugging flag xxx +
  • --nodebug=xxx turns off debugging flag xxx +
  • --flush Flush the output streams often (aids debugging). +
  • --check Run a consistency check over the CIL after every operation. +
  • --nocheck turns off consistency checking of CIL. +
  • --noPrintLn Don't output #line directives in the output. +
  • --commPrintLn Print #line directives in the output, but + put them in comments. +
  • --log=xxx Set the name of the log file. By default stderr is used +
  • --MSVC Enable MSVC compatibility. Default is GNU. +
  • --ignore-merge-conflicts ignore merging conflicts. +
  • --extrafiles=filename: the name of a file that contains + a list of additional files to process, separated by whitespace. +
  • --stats Print statistics about the running time of the + parser, conversion to CIL, etc. Also prints memory-usage + statistics. You can time parts of your own code as well. Calling + (Stats.time “label” func arg) will evaluate (func arg) + and remember how long this takes. If you call Stats.time + repeatedly with the same label, CIL will report the aggregate + time.
    +
    +If available, CIL uses the x86 performance counters for these + stats. This is very precise, but results in “wall-clock time.” + To report only user-mode time, find the call to Stats.reset in + main.ml, and change it to Stats.reset false.
    +
    +Lowering Options +
  • --noLowerConstants do not lower constant expressions. +
  • --noInsertImplicitCasts do not insert implicit casts. +
  • --forceRLArgEval Forces right to left evaluation of function arguments. +
  • --disallowDuplication Prevent small chunks of code from being duplicated. +
  • --keepunused Do not remove the unused variables and types. +
  • --rmUnusedInlines Delete any unused inline functions. This is the default in MSVC mode.
    +
    +Output Options: +
  • --printCilAsIs Do not try to simplify the CIL when + printing. Without this flag, CIL will attempt to produce prettier + output by e.g. changing while(1) into more meaningful loops. +
  • --noWrap do not wrap long lines when printing +
  • --out=xxx the name of the output CIL file. cilly + sets this for you. +
  • --mergedout=xxx specify the name of the merged file +
  • --cabsonly=xxx CABS output file name +
    +
    + Selected features. See Section 8 for more information. +
  • --dologcalls. Insert code in the processed source to print the name of +functions as are called. Implemented in src/ext/logcalls.ml. +
  • --dologwrites. Insert code in the processed source to print the +address of all memory writes. Implemented in src/ext/logwrites.ml. +
  • --dooneRet. Make each function have at most one 'return'. +Implemented in src/ext/oneret.ml. +
  • --dostackGuard. Instrument function calls and returns to +maintain a separate stack for return addresses. Implemeted in +src/ext/heapify.ml. +
  • --domakeCFG. Make the program look more like a CFG. Implemented +in src/cil.ml. +
  • --dopartial. Do interprocedural partial evaluation and +constant folding. Implemented in src/ext/partial.ml. +
  • --dosimpleMem. Simplify all memory expressions. Implemented in +src/ext/simplemem.ml.
    +
    +For an up-to-date list of available options, run cilly.asm --help.
+
+Previous +Up +Next + + diff --git a/cil/doc/cil009.html b/cil/doc/cil009.html new file mode 100644 index 0000000..f408d00 --- /dev/null +++ b/cil/doc/cil009.html @@ -0,0 +1,48 @@ + + + + + + + + + + + + + +Controlling CIL + + + +Previous +Up +Next +
+ +

9  Controlling CIL

+In the process of converting a C file to CIL we drop the unused prototypes +and even inline function definitions. This results in much smaller files. If +you do not want this behavior then you must pass the --keepunused argument +to the CIL application.
+
+Alternatively you can put the following pragma in the code (instructing CIL +to specifically keep the declarations and definitions of the function +func1 and variable var2, the definition of type foo and of +structure bar): +

+#pragma cilnoremove("func1", "var2", "type foo", "struct bar")
+
+
+Previous +Up +Next + + diff --git a/cil/doc/cil010.html b/cil/doc/cil010.html new file mode 100644 index 0000000..e7b1e4b --- /dev/null +++ b/cil/doc/cil010.html @@ -0,0 +1,100 @@ + + + + + + + + + + + + + +GCC Extensions + + + +Previous +Up +Next +
+ +

10  GCC Extensions

+The CIL parser handles most of the gcc +extensions +and compiles them to CIL. The following extensions are not handled (note that +we are able to compile a large number of programs, including the Linux kernel, +without encountering these): +
  1. +Nested function definitions. +
  2. Constructing function calls. +
  3. Naming an expression's type. +
  4. Complex numbers +
  5. Hex floats +
  6. Subscripts on non-lvalue arrays. +
  7. Forward function parameter declarations +
+The following extensions are handled, typically by compiling them away: +
  1. +Attributes for functions, variables and types. In fact, we have a clear +specification (see Section 6.4) of how attributes are interpreted. The +specification extends that of gcc. +
  2. Old-style function definitions and prototypes. These are translated to +new-style. +
  3. Locally-declared labels. As part of the translation to CIL, we generate +new labels as needed. +
  4. Labels as values and computed goto. This allows a program to take the +address of a label and to manipulate it as any value and also to perform a +computed goto. We compile this by assigning each label whose address is taken +a small integer that acts as its address. Every computed goto in the body +of the function is replaced with a switch statement. If you want to invoke +the label from another function, you are on your own (the gcc +documentation says the same.) +
  5. Generalized lvalues. You can write code like (a, b) += 5 and it gets +translated to CIL. +
  6. Conditionals with omitted operands. Things like x ? : y are +translated to CIL. +
  7. Double word integers. The type long long and the LL suffix on +constants is understood. This is currently interpreted as 64-bit integers. +
  8. Local arrays of variable length. These are converted to uses of +alloca, the array variable is replaced with a pointer to the allocated +array and the instances of sizeof(a) are adjusted to return the size of +the array and not the size of the pointer. +
  9. Non-constant local initializers. Like all local initializers these are +compiled into assignments. +
  10. Compound literals. These are also turned into assignments. +
  11. Designated initializers. The CIL parser actually supports the full ISO +syntax for initializers, which is more than both gcc and MSVC. I +(George) think that this is the most complicated part of the C language and +whoever designed it should be banned from ever designing languages again. +
  12. Case ranges. These are compiled into separate cases. There is no code +duplication, just a larger number of case statements. +
  13. Transparent unions. This is a strange feature that allows you to define +a function whose formal argument has a (tranparent) union type, but the +argument is called as if it were the first element of the union. This is +compiled away by saying that the type of the formal argument is that of the +first field, and the first thing in the function body we copy the formal into +a union.
    +
    +
  14. Inline assembly-language. The full syntax is supported and it is carried +as such in CIL.
    +
    +
  15. Function names as strings. The identifiers __FUNCTION__ and +__PRETTY_FUNCTION__ are replaced with string literals.
    +
    +
  16. Keywords typeof, alignof, inline are supported. +
+
+Previous +Up +Next + + diff --git a/cil/doc/cil011.html b/cil/doc/cil011.html new file mode 100644 index 0000000..975c8dd --- /dev/null +++ b/cil/doc/cil011.html @@ -0,0 +1,53 @@ + + + + + + + + + + + + + +CIL Limitations + + + +Previous +Up +Next +
+ +

11  CIL Limitations

+There are several implementation details of CIL that might make it unusable + or less than ideal for certain tasks: +
  • +CIL operates after preprocessing. If you need to see comments, for +example, you cannot use CIL. But you can use attributes and pragmas instead. +And there is some support to help you patch the include files before they are +seen by the preprocessor. For example, this is how we turn some +#defines that we don't like into function calls.
    +
    +
  • CIL does transform the code in a non-trivial way. This is done in order +to make most analyses easier. But if you want to see the code e1, e2++ +exactly as it appears in the code, then you should not use CIL.
    +
    +
  • CIL removes all local scopes and moves all variables to function +scope. It also separates a declaration with an initializer into a declaration +plus an assignment. The unfortunate effect of this transformation is that +local variables cannot have the const qualifier.
+
+Previous +Up +Next + + diff --git a/cil/doc/cil012.html b/cil/doc/cil012.html new file mode 100644 index 0000000..5d18fd5 --- /dev/null +++ b/cil/doc/cil012.html @@ -0,0 +1,133 @@ + + + + + + + + + + + + + +Known Bugs and Limitations + + + +Previous +Up +Next +
+ +

12  Known Bugs and Limitations

+
  • In the new versions of glibc there is a function + __builtin_va_arg that takes a type as its second argument. CIL + handles that through a slight trick. As it parses the function it changes a + call like: +
    +  mytype x = __builtin_va_arg(marker, mytype)
+
    into +
    + mytype x;
+ __builtin_va_arg(marker, sizeof(mytype), &x);
+
    + The latter form is used internally in CIL. However, the CIL pretty printer + will try to emit the original code.
    +
    +Similarly, __builtin_types_compatible_p(t1, t2), which takes + types as arguments, is represented internally as + __builtin_types_compatible_p(sizeof t1, sizeof t2), but the + sizeofs are removed when printing.
    +
    +
  • The implementation of bitsSizeOf does not take into account the +packing pragmas. However it was tested to be accurate on cygwin/gcc-2.95.3, +Linux/gcc-2.95.3 and on Windows/MSVC.
    +
    +
  • We do not support tri-graph sequences (ISO 5.2.1.1).
    +
    +
  • GCC has a strange feature called “extern inline”. Such a function can +be defined twice: first with the “extern inline” specifier and the second +time without it. If optimizations are turned off then the “extern inline” +definition is considered a prototype (its body is ignored). If optimizations +are turned on then the extern inline function is inlined at all of its +occurrences from the point of its definition all the way to the point where the +(optional) second definition appears. No body is generated for an extern +inline function. A body is generated for the real definition and that one is +used in the rest of the file.
    +
    +CIL will rename your extern inline function (and its uses) with the suffix + __extinline. This means that if you have two such definition, that do + different things and the optimizations are not on, then the CIL version might + compute a different answer !
    +
    +Also, if you have multiple extern inline declarations then CIL will ignore +but the first one. This is not so bad because GCC itself would not like it.
    +
    +
  • There are still a number of bugs in handling some obscure features of +GCC. For example, when you use variable-length arrays, CIL turns them into +calls to alloca. This means that they are deallocated when the function +returns and not when the local scope ends.
    +
    +Variable-length arrays are not supported as fields of a struct or union.
    +
    +
  • CIL cannot parse arbitrary #pragma directives. Their + syntax must follow gcc's attribute syntax to be understood. If you + need a pragma that does not follow gcc syntax, add that pragma's name + to no_parse_pragma in src/frontc/clexer.mll to indicate that + CIL should treat that pragma as a monolithic string rather than try + to parse its arguments.
    +
    +CIL cannot parse a line containing an empty #pragma.
    +
    +
  • CIL only parses #pragma directives at the "top level", this is, + outside of any enum, structure, union, or function definitions.
    +
    +If your compiler uses pragmas in places other than the top-level, + you may have to preprocess the sources in a special way (sed, perl, + etc.) to remove pragmas from these locations.
    +
    +
  • CIL cannot parse the following code (fixing this problem would require +extensive hacking of the LALR grammar): +
    
+int bar(int ()); // This prototype cannot be parsed
+int bar(int x()); // If you add a name to the function, it works
+int bar(int (*)()); // This also works (and it is more appropriate)
+

    +
    +
  • CIL also cannot parse certain K&R old-style prototypes with missing +return type: +
    
+g(); // This cannot be parsed
+int g(); // This is Ok
+

    +
    +
  • CIL does not understand some obscure combinations of type specifiers +(“signed” and “unsigned” applied to typedefs that themselves contain a +sign specification; you could argue that this should not be allowed anyway): +
    
+typedef signed char __s8;
+__s8 unsigned uchartest; // This is unsigned char for gcc
+

    +
    +
  • The statement x = 3 + x ++ will perform the increment of x + before the assignment, while gcc delays the increment after the + assignment. It turned out that this behavior is much easier to implement + than gcc's one, and either way is correct (since the behavior is unspecified + in this case). Similarly, if you write x = x ++; then CIL will perform + the increment before the assignment, whereas GCC and MSVC will perform it + after the assignment. +
+
+Previous +Up +Next + + diff --git a/cil/doc/cil015.html b/cil/doc/cil015.html new file mode 100644 index 0000000..a3dff7d --- /dev/null +++ b/cil/doc/cil015.html @@ -0,0 +1,60 @@ + + + + + + + + + + + + + +Debugging support + + + +Previous +Up +Next +
+ +

15  Debugging support

+Most of the time we debug our code using the Errormsg module along with the +pretty printer. But if you want to use the Ocaml debugger here is an easy way +to do it. Say that you want to debug the invocation of cilly that arises out +of the following command: +
+cilly -c hello.c 
+
+ You must follow the installation instructions +to install the Elist support files for ocaml and to extend your .emacs +appropriately. Then from within Emacs you do +
+ALT-X my-camldebug
+
+ This will ask you for the command to use for running the Ocaml debugger +(initially the default will be “ocamldebug” or the last command you +introduced). You use the following command: +
+cilly --ocamldebug -c hello.c 
+
+ This will run cilly as usual and invoke the Ocaml debugger when the cilly +engine starts. The advantage of this way of invoking the debugger is that the +directory search paths are set automatically and the right set or arguments is +passed to the debugger.
+
+
+Previous +Up +Next + + diff --git a/cil/doc/cil016.html b/cil/doc/cil016.html new file mode 100644 index 0000000..3191a9d --- /dev/null +++ b/cil/doc/cil016.html @@ -0,0 +1,342 @@ + + + + + + + + + + + + + +Who Says C is Simple? + + + +Previous +Up +Next +
+ +

16  Who Says C is Simple?

+When I (George) started to write CIL I thought it was going to take two weeks. +Exactly a year has passed since then and I am still fixing bugs in it. This +gross underestimate was due to the fact that I thought parsing and making +sense of C is simple. You probably think the same. What I did not expect was +how many dark corners this language has, especially if you want to parse +real-world programs such as those written for GCC or if you are more ambitious +and you want to parse the Linux or Windows NT sources (both of these were +written without any respect for the standard and with the expectation that +compilers will be changed to accommodate the program).
+
+The following examples were actually encountered either in real programs or +are taken from the ISO C99 standard or from the GCC's testcases. My first +reaction when I saw these was: Is this C?. The second one was : What the hell does it mean?.
+
+If you are contemplating doing program analysis for C on abstract-syntax +trees then your analysis ought to be able to handle these things. Or, you can +use CIL and let CIL translate them into clean C code.
+
+ +

16.1  Standard C

+
  1. Why does the following code return 0 for most values of x? (This +should be easy.) +
    
+  int x;
+  return x == (1 && x);
+
    +See the CIL output for this +code fragment
    +
    +
  2. Why does the following code return 0 and not -1? (Answer: because +sizeof is unsigned, thus the result of the subtraction is unsigned, thus +the shift is logical.) +
    
+ return ((1 - sizeof(int)) >> 32);
+
    +See the CIL output for this +code fragment
    +
    +
  3. Scoping rules can be tricky. This function returns 5. +
    
+int x = 5;
+int f() {
+  int x = 3;
+  {
+    extern int x;
+    return x;
+  }
+}
+
    +See the CIL output for this +code fragment
    +
    +
  4. Functions and function pointers are implicitly converted to each other. +
    
+int (*pf)(void);
+int f(void) {
+
+   pf = &f; // This looks ok
+   pf = ***f; // Dereference a function?
+   pf(); // Invoke a function pointer?     
+   (****pf)();  // Looks strange but Ok
+   (***************f)(); // Also Ok             
+}
+
    +See the CIL output for this +code fragment
    +
    +
  5. Initializer with designators are one of the hardest parts about ISO C. +Neither MSVC or GCC implement them fully. GCC comes close though. What is the +final value of i.nested.y and i.nested.z? (Answer: 2 and respectively +6). +
    
+struct { 
+   int x; 
+   struct { 
+       int y, z; 
+   } nested;
+} i = { .nested.y = 5, 6, .x = 1, 2 };               
+
    +See the CIL output for this +code fragment
    +
    +
  6. This is from c-torture. This function returns 1. +
    
+typedef struct
+{
+  char *key;
+  char *value;
+} T1;
+
+typedef struct
+{
+  long type;
+  char *value;
+} T3;
+
+T1 a[] =
+{
+  {
+    "",
+    ((char *)&((T3) {1, (char *) 1}))
+  }
+};
+int main() {
+   T3 *pt3 = (T3*)a[0].value;
+   return pt3->value;
+}
+
    +See the CIL output for this +code fragment
    +
    +
  7. Another one with constructed literals. This one is legal according to +the GCC documentation but somehow GCC chokes on (it works in CIL though). This +code returns 2. +
    
+ return ((int []){1,2,3,4})[1];
+
    +See the CIL output for this +code fragment
    +
    +
  8. In the example below there is one copy of “bar” and two copies of + “pbar” (static prototypes at block scope have file scope, while for all + other types they have block scope). +
    
+  int foo() {
+     static bar();
+     static (*pbar)() = bar;
+
+  }
+
+  static bar() { 
+    return 1;
+  }
+
+  static (*pbar)() = 0;
+
    +See the CIL output for this +code fragment
    +
    +
  9. Two years after heavy use of CIL, by us and others, I discovered a bug + in the parser. The return value of the following function depends on what + precedence you give to casts and unary minus: +
    
+  unsigned long foo() {
+    return (unsigned long) - 1 / 8;
+  }
+
    +See the CIL output for this +code fragment
    +
    +The correct interpretation is ((unsigned long) - 1) / 8, which is a + relatively large number, as opposed to (unsigned long) (- 1 / 8), which + is 0.
+ +

16.2  GCC ugliness

+
  1. GCC has generalized lvalues. You can take the address of a lot of +strange things: +
    
+  int x, y, z;
+  return &(x ? y : z) - & (x++, x);
+
    +See the CIL output for this +code fragment
    +
    +
  2. GCC lets you omit the second component of a conditional expression. +
    
+  extern int f();
+  return f() ? : -1; // Returns the result of f unless it is 0
+
    +See the CIL output for this +code fragment
    +
    +
  3. Computed jumps can be tricky. CIL compiles them away in a fairly clean +way but you are on your own if you try to jump into another function this way. +
    
+static void *jtab[2]; // A jump table
+static int doit(int x){
+ 
+  static int jtab_init = 0;
+  if(!jtab_init) { // Initialize the jump table
+    jtab[0] = &&lbl1;
+    jtab[1] = &&lbl2;
+    jtab_init = 1;
+  }
+  goto *jtab[x]; // Jump through the table
+lbl1:
+  return 0;
+lbl2:
+  return 1;
+}
+ 
+int main(void){
+  if (doit(0) != 0) exit(1);
+  if (doit(1) != 1) exit(1);
+  exit(0);
+}
+
    +See the CIL output for this +code fragment
    +
    +
  4. A cute little example that we made up. What is the returned value? +(Answer: 1); +
    
+ return ({goto L; 0;}) && ({L: 5;});
+
    +See the CIL output for this +code fragment
    +
    +
  5. extern inline is a strange feature of GNU C. Can you guess what the +following code computes? +
    
+extern inline foo(void) { return 1; }
+int firstuse(void) { return foo(); }
+
+// A second, incompatible definition of foo
+int foo(void) { return 2; }
+
+int main() {
+    return foo() + firstuse();
+}
+
    +See the CIL output for this +code fragment
    +
    +The answer depends on whether the optimizations are turned on. If they are +then the answer is 3 (the first definition is inlined at all occurrences until +the second definition). If the optimizations are off, then the first +definition is ignore (treated like a prototype) and the answer is 4.
    +
    +CIL will misbehave on this example, if the optimizations are turned off (it + always returns 3).
    +
    +
  6. GCC allows you to cast an object of a type T into a union as long as the +union has a field of that type: +
    
+union u { 
+   int i; 
+   struct s { 
+      int i1, i2;
+   } s;
+};
+
+union u x = (union u)6;
+
+int main() {
+  struct s y = {1, 2};
+  union u  z = (union u)y;
+}
+
    +See the CIL output for this +code fragment
    +
    +
  7. GCC allows you to use the __mode__ attribute to specify the size +of the integer instead of the standard char, short and so on: +
    
+int __attribute__ ((__mode__ (  __QI__ ))) i8;
+int __attribute__ ((__mode__ (  __HI__ ))) i16;
+int __attribute__ ((__mode__ (  __SI__ ))) i32;
+int __attribute__ ((__mode__ (  __DI__ ))) i64;
+
    +See the CIL output for this +code fragment
    +
    +
  8. The “alias” attribute on a function declaration tells the + linker to treat this declaration as another name for the specified + function. CIL will replace the declaration with a trampoline + function pointing to the specified target. +
    
+    static int bar(int x, char y) {
+      return x + y;
+    }
+
+    //foo is considered another name for bar.
+    int foo(int x, char y) __attribute__((alias("bar")));
+
    +See the CIL output for this +code fragment
+ +

16.3  Microsoft VC ugliness

+This compiler has few extensions, so there is not much to say here. +
  1. +Why does the following code return 0 and not -1? (Answer: because of a +bug in Microsoft Visual C. It thinks that the shift is unsigned just because +the second operator is unsigned. CIL reproduces this bug when in MSVC mode.) +
    
+ return -3 >> (8 * sizeof(int));
+

    +
    +
  2. Unnamed fields in a structure seem really strange at first. It seems +that Microsoft Visual C introduced this extension, then GCC picked it up (but +in the process implemented it wrongly: in GCC the field y overlaps with +x!). +
    
+struct {
+  int x;
+  struct {
+     int y, z;
+     struct {
+       int u, v;
+     };
+ };
+} a;
+return a.x + a.y + a.z + a.u + a.v;
+
    +See the CIL output for this +code fragment
+
+Previous +Up +Next + + diff --git a/cil/doc/cil017.html b/cil/doc/cil017.html new file mode 100644 index 0000000..a9e04eb --- /dev/null +++ b/cil/doc/cil017.html @@ -0,0 +1,53 @@ + + + + + + + + + + + + + +Authors + + + +Previous +Up +Next +
+ +

17  Authors

+The CIL parser was developed starting from Hugues Casse's frontc +front-end for C although all the files from the frontc distribution have +been changed very extensively. The intermediate language and the elaboration +stage are all written from scratch. The main author is +George Necula, with significant +contributions from Scott McPeak, +Westley Weimer, +Ben Liblit, +Matt Harren, +Raymond To and Aman Bhargava.
+
+This work is based upon work supported in part by the National Science +Foundation under Grants No. 9875171, 0085949 and 0081588, and gifts from +Microsoft Research. Any opinions, findings, and conclusions or recommendations +expressed in this material are those of the author(s) and do not necessarily +reflect the views of the National Science Foundation or the other sponsors.
+
+
+Previous +Up +Next + + diff --git a/cil/doc/cil018.html b/cil/doc/cil018.html new file mode 100644 index 0000000..dc039ea --- /dev/null +++ b/cil/doc/cil018.html @@ -0,0 +1,71 @@ + + + + + + + + + + + + + +License + + + +Previous +Up +Next +
+ +

18  License

+Copyright (c) 2001-2005, +
  • +George C. Necula <necula@cs.berkeley.edu> +
  • Scott McPeak <smcpeak@cs.berkeley.edu> +
  • Wes Weimer <weimer@cs.berkeley.edu> +
  • Ben Liblit <liblit@cs.wisc.edu> +
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met:
+
+1. Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright notice, +this list of conditions and the following disclaimer in the documentation +and/or other materials provided with the distribution.
+
+3. The names of the contributors may not be used to endorse or promote +products derived from this software without specific prior written +permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE +LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR +CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF +SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN +CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE.
+
+
+Previous +Up +Next + + diff --git a/cil/doc/cil019.html b/cil/doc/cil019.html new file mode 100644 index 0000000..84e3f8b --- /dev/null +++ b/cil/doc/cil019.html @@ -0,0 +1,45 @@ + + + + + + + + + + + + + +Bug reports + + + +Previous +Up +Next +
+ +

19  Bug reports

+We are certain that there are still some remaining bugs in CIL. If you find +one please file a bug report in our Source Forge space +http://sourceforge.net/projects/cil.
+
+You can find there the latest announcements, a source distribution, +bug report submission instructions and a mailing list: cil-users[at +sign]lists.sourceforge.net. Please use this list to ask questions about CIL, +as it will ensure your message is viewed by a broad audience.
+
+
+Previous +Up +Next + + diff --git a/cil/doc/cilly.html b/cil/doc/cilly.html new file mode 100644 index 0000000..1a28758 --- /dev/null +++ b/cil/doc/cilly.html @@ -0,0 +1,187 @@ + + + + + + + + + + + + + +How to Use CIL + + + +Previous +Up +Next +
+ +

5  How to Use CIL


+
+There are two predominant ways to use CIL to write a program analysis or +transformation. The first is to phrase your analysis as a module that is +called by our existing driver. The second is to use CIL as a stand-alone +library. We highly recommend that you use cilly, our driver.
+
+ +

5.1  Using cilly, the CIL driver

+The most common way to use CIL is to write an Ocaml module containing your +analysis and transformation, which you then link into our boilerplate +driver application called cilly. cilly is a Perl script that +processes and mimics GCC and MSVC command-line arguments and then +calls cilly.byte.exe or cilly.asm.exe (CIL's Ocaml executable).
+
+An example of such module is logwrites.ml, a transformation that is +distributed with CIL and whose purpose is to instrument code to print the +addresses of memory locations being written. (We plan to release a +C-language interface to CIL so that you can write your analyses in C +instead of Ocaml.) See Section 8 for a survey of other example +modules.
+
+Assuming that you have written /home/necula/logwrites.ml, +here is how you use it: +
  1. Modify logwrites.ml so that it includes a CIL “feature + descriptor” like this: +
    +let feature : featureDescr = 
+  { fd_name = "logwrites";              
+    fd_enabled = ref false;
+    fd_description = "generation of code to log memory writes";
+    fd_extraopt = [];
+    fd_doit = 
+    (function (f: file) -> 
+      let lwVisitor = new logWriteVisitor in
+      visitCilFileSameGlobals lwVisitor f)
+  } 
+
    The fd_name field names the feature and its associated + command-line arguments. The fd_enabled field is a bool ref. + “fd_doit” will be invoked if !fd_enabled is true after + argument parsing, so initialize the ref cell to true if you want + this feature to be enabled by default.
    +
    +When the user passes the --dologwrites + command-line option to cilly, the variable associated with the + fd_enabled flag is set and the fd_doit function is called + on the Cil.file that represents the merger (see Section 13) of + all C files listed as arguments.
    +
    +
  2. Invoke configure with the arguments +
    +./configure EXTRASRCDIRS=/home/necula EXTRAFEATURES=logwrites
+
    + This step works if each feature is packaged into its own ML file, and the +name of the entry point in the file is feature.
    +
    +An alternative way to specify the new features is to change the build files +yourself, as explained below. You'll need to use this method if a single +feature is split across multiple files. +
    1. + Put logwrites.ml in the src or src/ext directory. This + will make sure that make can find it. If you want to put it in some + other directory, modify Makefile.in and add to SOURCEDIRS your + directory. Alternately, you can create a symlink from src or + src/ext to your file.
      +
      +
    2. Modify the Makefile.in and add your module to the + CILLY_MODULES or + CILLY_LIBRARY_MODULES variables. The order of the modules matters. Add + your modules somewhere after cil and before main.
      +
      +
    3. If you have any helper files for your module, add those to + the makefile in the same way. e.g.: +
      +CILLY_MODULES = $(CILLY_LIBRARY_MODULES) \
+                myutilities1 myutilities2 logwrites \
+                main
+
      + Again, order is important: myutilities2.ml will be able to refer + to Myutilities1 but not Logwrites. If you have any ocamllex or ocamlyacc + files, add them to both CILLY_MODULES and either MLLS or + MLYS.
      +
      +
    4. Modify main.ml so that your new feature descriptor appears in + the global list of CIL features. +
      +let features : C.featureDescr list = 
+  [ Logcalls.feature;
+    Oneret.feature;    
+    Heapify.feature1;  
+    Heapify.feature2;
+    makeCFGFeature; 
+    Partial.feature;
+    Simplemem.feature;
+    Logwrites.feature;  (* add this line to include the logwrites feature! *)
+  ] 
+  @ Feature_config.features 
+
      + Features are processed in the order they appear on this list. Put + your feature last on the list if you plan to run any of CIL's + built-in features (such as makeCFGfeature) before your own.

    +Standard code in cilly takes care of adding command-line arguments, + printing the description, and calling your function automatically. + Note: do not worry about introducing new bugs into CIL by adding a single + line to the feature list.
    +
    +
  3. Now you can invoke the cilly application on a preprocessed file, or + instead use the cilly driver which provides a convenient compiler-like + interface to cilly. See Section 7 for details using cilly. + Remember to enable your analysis by passing the right argument (e.g., + --dologwrites).
+ +

5.2  Using CIL as a library

+CIL can also be built as a library that is called from your stand-alone +application. Add cil/src, cil/src/frontc, cil/obj/x86_LINUX +(or cil/obj/x86_WIN32) to your Ocaml project -I include paths. +Building CIL will also build the library cil/obj/*/cil.cma (or +cil/obj/*/cil.cmxa). You can then link your application against that +library.
+
+You can call the Frontc.parse: string -> unit -> Cil.file function with +the name of a file containing the output of the C preprocessor. +The Mergecil.merge: Cil.file list -> string -> Cil.file function merges +multiple files. You can then invoke your analysis function on the resulting +Cil.file data structure. You might want to call +Rmtmps.removeUnusedTemps first to clean up the prototypes and variables +that are not used. Then you can call the function Cil.dumpFile: +cilPrinter -> out_channel -> Cil.file -> unit to print the file to a +given output channel. A good cilPrinter to use is +defaultCilPrinter.
+
+Check out src/main.ml and bin/cilly for other good ideas +about high-level file processing. Again, we highly recommend that you just +our cilly driver so that you can avoid spending time re-inventing the +wheel to provide drop-in support for standard makefiles.
+
+Here is a concrete example of compiling and linking your project against +CIL. Imagine that your program analysis or transformation is contained in +the single file main.ml. +
+$ ocamlopt -c -I $(CIL)/obj/x86_LINUX/ main.ml
+$ ocamlopt -ccopt -L$(CIL)/obj/x86_LINUX/ -o main unix.cmxa str.cmxa \ 
+        $(CIL)/obj/x86_LINUX/cil.cmxa main.cmx
+
+The first line compiles your analysis, the second line links it against CIL +(as a library) and the Ocaml Unix library. For more information about +compiling and linking Ocaml programs, see the Ocaml home page +at http://caml.inria.fr/ocaml/.
+
+In the next section we give an overview of the API that you can use +to write your analysis and transformation.
+
+
+Previous +Up +Next + + diff --git a/cil/doc/cilpp.haux b/cil/doc/cilpp.haux new file mode 100644 index 0000000..1b9fa16 --- /dev/null +++ b/cil/doc/cilpp.haux @@ -0,0 +1,64 @@ +\@addtocsec{htoc}{1}{0}{\@print{1}\quad{}Introduction} +\@addtocsec{htoc}{2}{0}{\@print{2}\quad{}Installation} +\@addtocsec{htoc}{3}{0}{\@print{3}\quad{}Distribution Contents} +\@addtocsec{htoc}{4}{0}{\@print{4}\quad{}Compiling C to CIL} +\newlabel{sec-cabs2cil}{{4}{X}} +\@addtocsec{htoc}{5}{0}{\@print{5}\quad{}How to Use CIL} +\newlabel{sec-cil}{{5}{X}} +\@addtocsec{htoc}{6}{1}{\@print{5.1}\quad{}Using \t{cilly}, the CIL driver} +\@addtocsec{htoc}{7}{1}{\@print{5.2}\quad{}Using CIL as a library} +\@addtocsec{htoc}{8}{0}{\@print{6}\quad{}CIL API Documentation} +\newlabel{sec-api}{{6}{X}} +\@addtocsec{htoc}{9}{1}{\@print{6.1}\quad{}Using the visitor} +\newlabel{sec-visitor}{{6.1}{X}} +\@addtocsec{htoc}{10}{1}{\@print{6.2}\quad{}Interpreted Constructors and Deconstructors} +\@addtocsec{htoc}{11}{2}{\@print{6.2.1}\quad{}Performance considerations for interpreted constructors} +\@addtocsec{htoc}{12}{1}{\@print{6.3}\quad{}Printing and Debugging support} +\@addtocsec{htoc}{13}{1}{\@print{6.4}\quad{}Attributes} +\newlabel{sec-attrib}{{6.4}{X}} +\@addtocsec{htoc}{14}{0}{\@print{7}\quad{}The CIL Driver} +\newlabel{sec-driver}{{7}{X}} +\@addtocsec{htoc}{15}{1}{\@print{7.1}\quad{}\t{cilly} Options} +\@addtocsec{htoc}{16}{1}{\@print{7.2}\quad{}\t{cilly.asm} Options} +\newlabel{sec-cilly-asm-options}{{7.2}{X}} +\@addtocsec{htoc}{17}{0}{\@print{8}\quad{}Library of CIL Modules} +\newlabel{sec-Extension}{{8}{X}} +\@addtocsec{htoc}{18}{1}{\@print{8.1}\quad{}Control-Flow Graphs} +\newlabel{sec-cfg}{{8.1}{X}} +\@addtocsec{htoc}{19}{2}{\@print{8.1.1}\quad{}The CFG module (new in CIL 1.3.5)} +\@addtocsec{htoc}{20}{2}{\@print{8.1.2}\quad{}Simplified control flow} +\@addtocsec{htoc}{21}{1}{\@print{8.2}\quad{}Data flow analysis framework} +\@addtocsec{htoc}{22}{1}{\@print{8.3}\quad{}Dominators} +\@addtocsec{htoc}{23}{1}{\@print{8.4}\quad{}Points-to Analysis} +\@addtocsec{htoc}{24}{1}{\@print{8.5}\quad{}StackGuard} +\@addtocsec{htoc}{25}{1}{\@print{8.6}\quad{}Heapify} +\@addtocsec{htoc}{26}{1}{\@print{8.7}\quad{}One Return} +\@addtocsec{htoc}{27}{1}{\@print{8.8}\quad{}Partial Evaluation and Constant Folding} +\@addtocsec{htoc}{28}{1}{\@print{8.9}\quad{}Reaching Definitions} +\@addtocsec{htoc}{29}{1}{\@print{8.10}\quad{}Available Expressions} +\@addtocsec{htoc}{30}{1}{\@print{8.11}\quad{}Liveness Analysis} +\@addtocsec{htoc}{31}{1}{\@print{8.12}\quad{}Dead Code Elimination} +\@addtocsec{htoc}{32}{1}{\@print{8.13}\quad{}Simple Memory Operations} +\@addtocsec{htoc}{33}{1}{\@print{8.14}\quad{}Simple Three-Address Code} +\@addtocsec{htoc}{34}{1}{\@print{8.15}\quad{}Converting C to C++} +\@addtocsec{htoc}{35}{0}{\@print{9}\quad{}Controlling CIL} +\@addtocsec{htoc}{36}{0}{\@print{10}\quad{}GCC Extensions} +\@addtocsec{htoc}{37}{0}{\@print{11}\quad{}CIL Limitations} +\@addtocsec{htoc}{38}{0}{\@print{12}\quad{}Known Bugs and Limitations} +\@addtocsec{htoc}{39}{0}{\@print{13}\quad{}Using the merger} +\newlabel{sec-merger}{{13}{X}} +\@addtocsec{htoc}{40}{0}{\@print{14}\quad{}Using the patcher} +\newlabel{sec-patcher}{{14}{X}} +\@addtocsec{htoc}{41}{0}{\@print{15}\quad{}Debugging support} +\newlabel{sec-debugger}{{15}{X}} +\@addtocsec{htoc}{42}{0}{\@print{16}\quad{}Who Says C is Simple?} +\newlabel{sec-simplec}{{16}{X}} +\@addtocsec{htoc}{43}{1}{\@print{16.1}\quad{}Standard C} +\@addtocsec{htoc}{44}{1}{\@print{16.2}\quad{}GCC ugliness} +\newlabel{sec-ugly-gcc}{{16.2}{X}} +\@addtocsec{htoc}{45}{1}{\@print{16.3}\quad{}Microsoft VC ugliness} +\@addtocsec{htoc}{46}{0}{\@print{17}\quad{}Authors} +\@addtocsec{htoc}{47}{0}{\@print{18}\quad{}License} +\@addtocsec{htoc}{48}{0}{\@print{19}\quad{}Bug reports} +\@addtocsec{htoc}{49}{0}{\@print{20}\quad{}Changes} +\newlabel{sec-changes}{{20}{X}} diff --git a/cil/doc/cilpp.htoc b/cil/doc/cilpp.htoc new file mode 100644 index 0000000..d5bc0e5 --- /dev/null +++ b/cil/doc/cilpp.htoc @@ -0,0 +1,65 @@ +\begin{tocenv} +\tocitem \@locref{htoc1}{\begin{@norefs}\@print{1}\quad{}Introduction\end{@norefs}} +\tocitem \@locref{htoc2}{\begin{@norefs}\@print{2}\quad{}Installation\end{@norefs}} +\tocitem \@locref{htoc3}{\begin{@norefs}\@print{3}\quad{}Distribution Contents\end{@norefs}} +\tocitem \@locref{htoc4}{\begin{@norefs}\@print{4}\quad{}Compiling C to CIL\end{@norefs}} +\tocitem \@locref{htoc5}{\begin{@norefs}\@print{5}\quad{}How to Use CIL\end{@norefs}} +\begin{tocenv} +\tocitem \@locref{htoc6}{\begin{@norefs}\@print{5.1}\quad{}Using \t{cilly}, the CIL driver\end{@norefs}} +\tocitem \@locref{htoc7}{\begin{@norefs}\@print{5.2}\quad{}Using CIL as a library\end{@norefs}} +\end{tocenv} +\tocitem \@locref{htoc8}{\begin{@norefs}\@print{6}\quad{}CIL API Documentation\end{@norefs}} +\begin{tocenv} +\tocitem \@locref{htoc9}{\begin{@norefs}\@print{6.1}\quad{}Using the visitor\end{@norefs}} +\tocitem \@locref{htoc10}{\begin{@norefs}\@print{6.2}\quad{}Interpreted Constructors and Deconstructors\end{@norefs}} +\begin{tocenv} +\tocitem \@locref{htoc11}{\begin{@norefs}\@print{6.2.1}\quad{}Performance considerations for interpreted constructors\end{@norefs}} +\end{tocenv} +\tocitem \@locref{htoc12}{\begin{@norefs}\@print{6.3}\quad{}Printing and Debugging support\end{@norefs}} +\tocitem \@locref{htoc13}{\begin{@norefs}\@print{6.4}\quad{}Attributes\end{@norefs}} +\end{tocenv} +\tocitem \@locref{htoc14}{\begin{@norefs}\@print{7}\quad{}The CIL Driver\end{@norefs}} +\begin{tocenv} +\tocitem \@locref{htoc15}{\begin{@norefs}\@print{7.1}\quad{}\t{cilly} Options\end{@norefs}} +\tocitem \@locref{htoc16}{\begin{@norefs}\@print{7.2}\quad{}\t{cilly.asm} Options\end{@norefs}} +\end{tocenv} +\tocitem \@locref{htoc17}{\begin{@norefs}\@print{8}\quad{}Library of CIL Modules\end{@norefs}} +\begin{tocenv} +\tocitem \@locref{htoc18}{\begin{@norefs}\@print{8.1}\quad{}Control-Flow Graphs\end{@norefs}} +\begin{tocenv} +\tocitem \@locref{htoc19}{\begin{@norefs}\@print{8.1.1}\quad{}The CFG module (new in CIL 1.3.5)\end{@norefs}} +\tocitem \@locref{htoc20}{\begin{@norefs}\@print{8.1.2}\quad{}Simplified control flow\end{@norefs}} +\end{tocenv} +\tocitem \@locref{htoc21}{\begin{@norefs}\@print{8.2}\quad{}Data flow analysis framework\end{@norefs}} +\tocitem \@locref{htoc22}{\begin{@norefs}\@print{8.3}\quad{}Dominators\end{@norefs}} +\tocitem \@locref{htoc23}{\begin{@norefs}\@print{8.4}\quad{}Points-to Analysis\end{@norefs}} +\tocitem \@locref{htoc24}{\begin{@norefs}\@print{8.5}\quad{}StackGuard\end{@norefs}} +\tocitem \@locref{htoc25}{\begin{@norefs}\@print{8.6}\quad{}Heapify\end{@norefs}} +\tocitem \@locref{htoc26}{\begin{@norefs}\@print{8.7}\quad{}One Return\end{@norefs}} +\tocitem \@locref{htoc27}{\begin{@norefs}\@print{8.8}\quad{}Partial Evaluation and Constant Folding\end{@norefs}} +\tocitem \@locref{htoc28}{\begin{@norefs}\@print{8.9}\quad{}Reaching Definitions\end{@norefs}} +\tocitem \@locref{htoc29}{\begin{@norefs}\@print{8.10}\quad{}Available Expressions\end{@norefs}} +\tocitem \@locref{htoc30}{\begin{@norefs}\@print{8.11}\quad{}Liveness Analysis\end{@norefs}} +\tocitem \@locref{htoc31}{\begin{@norefs}\@print{8.12}\quad{}Dead Code Elimination\end{@norefs}} +\tocitem \@locref{htoc32}{\begin{@norefs}\@print{8.13}\quad{}Simple Memory Operations\end{@norefs}} +\tocitem \@locref{htoc33}{\begin{@norefs}\@print{8.14}\quad{}Simple Three-Address Code\end{@norefs}} +\tocitem \@locref{htoc34}{\begin{@norefs}\@print{8.15}\quad{}Converting C to C++\end{@norefs}} +\end{tocenv} +\tocitem \@locref{htoc35}{\begin{@norefs}\@print{9}\quad{}Controlling CIL\end{@norefs}} +\tocitem \@locref{htoc36}{\begin{@norefs}\@print{10}\quad{}GCC Extensions\end{@norefs}} +\tocitem \@locref{htoc37}{\begin{@norefs}\@print{11}\quad{}CIL Limitations\end{@norefs}} +\tocitem \@locref{htoc38}{\begin{@norefs}\@print{12}\quad{}Known Bugs and Limitations\end{@norefs}} +\tocitem \@locref{htoc39}{\begin{@norefs}\@print{13}\quad{}Using the merger\end{@norefs}} +\tocitem \@locref{htoc40}{\begin{@norefs}\@print{14}\quad{}Using the patcher\end{@norefs}} +\tocitem \@locref{htoc41}{\begin{@norefs}\@print{15}\quad{}Debugging support\end{@norefs}} +\tocitem \@locref{htoc42}{\begin{@norefs}\@print{16}\quad{}Who Says C is Simple?\end{@norefs}} +\begin{tocenv} +\tocitem \@locref{htoc43}{\begin{@norefs}\@print{16.1}\quad{}Standard C\end{@norefs}} +\tocitem \@locref{htoc44}{\begin{@norefs}\@print{16.2}\quad{}GCC ugliness\end{@norefs}} +\tocitem \@locref{htoc45}{\begin{@norefs}\@print{16.3}\quad{}Microsoft VC ugliness\end{@norefs}} +\end{tocenv} +\tocitem \@locref{htoc46}{\begin{@norefs}\@print{17}\quad{}Authors\end{@norefs}} +\tocitem \@locref{htoc47}{\begin{@norefs}\@print{18}\quad{}License\end{@norefs}} +\tocitem \@locref{htoc48}{\begin{@norefs}\@print{19}\quad{}Bug reports\end{@norefs}} +\tocitem \@locref{htoc49}{\begin{@norefs}\@print{20}\quad{}Changes\end{@norefs}} +\end{tocenv} diff --git a/cil/doc/ciltoc.html b/cil/doc/ciltoc.html new file mode 100644 index 0000000..7fe4c80 --- /dev/null +++ b/cil/doc/ciltoc.html @@ -0,0 +1,92 @@ + + + + + + + + + + + + + + + + + + + + + + +

+ + +
This document was translated from LATEX by +HEVEA.
+ diff --git a/cil/doc/contents_motif.gif b/cil/doc/contents_motif.gif new file mode 100644 index 0000000..5d3d016 Binary files /dev/null and b/cil/doc/contents_motif.gif differ diff --git a/cil/doc/examples/ex1.txt b/cil/doc/examples/ex1.txt new file mode 100644 index 0000000..2fe6c21 --- /dev/null +++ b/cil/doc/examples/ex1.txt @@ -0,0 +1,16 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex1.c" +long x ; +#line 3 "cilcode.tmp/ex1.c" +static long long y ; +#line 6 "cilcode.tmp/ex1.c" +int main(void) +{ + + { +#line 6 + return ((int )((long long )x + y)); +} +} diff --git a/cil/doc/examples/ex10.txt b/cil/doc/examples/ex10.txt new file mode 100644 index 0000000..7213b4c --- /dev/null +++ b/cil/doc/examples/ex10.txt @@ -0,0 +1,10 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex10.c" +char foo[13] = +#line 1 + { (char )'f', (char )'o', (char )'o', (char )' ', + (char )'p', (char )'l', (char )'u', (char )'s', + (char )' ', (char )'b', (char )'a', (char )'r', + (char )'\000'}; diff --git a/cil/doc/examples/ex11.txt b/cil/doc/examples/ex11.txt new file mode 100644 index 0000000..683df51 --- /dev/null +++ b/cil/doc/examples/ex11.txt @@ -0,0 +1,5 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex11.c" +char *foo = (char *)"foo plus bar "; diff --git a/cil/doc/examples/ex12.txt b/cil/doc/examples/ex12.txt new file mode 100644 index 0000000..d04d83d --- /dev/null +++ b/cil/doc/examples/ex12.txt @@ -0,0 +1,32 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 2 "cilcode.tmp/ex12.c" +struct foo { + int f1 ; + int f2 ; +}; +#line 1 "cilcode.tmp/ex12.c" +int main(void) +{ int x ; + struct foo a[3] ; + + { +#line 1 + x = 5; +#line 2 + a[0].f1 = 1; +#line 2 + a[0].f2 = 2; +#line 2 + a[1].f1 = 3; +#line 2 + a[1].f2 = 4; +#line 2 + a[2].f1 = 5; +#line 2 + a[2].f2 = 0; +#line 3 + return (0); +} +} diff --git a/cil/doc/examples/ex13.txt b/cil/doc/examples/ex13.txt new file mode 100644 index 0000000..6486ad6 --- /dev/null +++ b/cil/doc/examples/ex13.txt @@ -0,0 +1,21 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex13.c" +int x = 5; +#line 2 "cilcode.tmp/ex13.c" +int main(void) +{ int x___0 ; + int x___1 ; + + { +#line 3 + x___0 = 6; +#line 5 + x___1 = 7; +#line 6 + return (x___1); +#line 8 + return (x___0); +} +} diff --git a/cil/doc/examples/ex14.txt b/cil/doc/examples/ex14.txt new file mode 100644 index 0000000..72fc719 --- /dev/null +++ b/cil/doc/examples/ex14.txt @@ -0,0 +1,22 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex14.c" +int x = 5; +#line 5 +int main(void) ; +#line 5 "cilcode.tmp/ex14.c" +static int x___1 = 7; +#line 2 "cilcode.tmp/ex14.c" +int main(void) +{ int x___0 ; + + { +#line 3 + x___0 = 6; +#line 6 + return (x___1); +#line 8 + return (x___0); +} +} diff --git a/cil/doc/examples/ex15.txt b/cil/doc/examples/ex15.txt new file mode 100644 index 0000000..4f64ae9 --- /dev/null +++ b/cil/doc/examples/ex15.txt @@ -0,0 +1,14 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex15.c" +int foo(void) +{ int x ; + + { +#line 2 + x = 5; +#line 3 + return (0); +} +} diff --git a/cil/doc/examples/ex16.txt b/cil/doc/examples/ex16.txt new file mode 100644 index 0000000..82290c2 --- /dev/null +++ b/cil/doc/examples/ex16.txt @@ -0,0 +1,22 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex16.c" +extern int f(int ) ; +#line 1 "cilcode.tmp/ex16.c" +int main(void) +{ int x ; + int tmp ; + int tmp___0 ; + + { +#line 2 + tmp = x; +#line 2 + x ++; +#line 2 + tmp___0 = f(x); +#line 2 + return (tmp + tmp___0); +} +} diff --git a/cil/doc/examples/ex17.txt b/cil/doc/examples/ex17.txt new file mode 100644 index 0000000..20bbaa7 --- /dev/null +++ b/cil/doc/examples/ex17.txt @@ -0,0 +1,81 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex17.c" +int main(void) +{ int x ; + int y ; + int tmp ; + int z ; + int tmp___0 ; + + { +#line 2 + if (x) { +#line 2 + tmp = 2; + } else { +#line 2 + tmp = 4; + } +#line 2 + y = tmp; +#line 3 + if (x) { +#line 3 + tmp___0 = 1; + } else { +#line 3 + if (y) { +#line 3 + tmp___0 = 1; + } else { +#line 3 + tmp___0 = 0; + } + } +#line 3 + z = tmp___0; +#line 5 + if (x) { +#line 5 + if (y) { +#line 5 + return (0); + } else { +#line 5 + return (1); + } + } else { +#line 5 + return (1); + } +#line 8 + if (x) { +#line 8 + if (y) { + goto _L; + } else { + goto _L___0; + } + } else { + _L___0: /* CIL Label */ +#line 8 + if (z) { + _L: /* CIL Label */ +#line 8 + x ++; +#line 8 + y ++; +#line 8 + z ++; +#line 8 + x ++; +#line 8 + y ++; +#line 8 + return (z); + } + } +} +} diff --git a/cil/doc/examples/ex18.txt b/cil/doc/examples/ex18.txt new file mode 100644 index 0000000..bcdb7ef --- /dev/null +++ b/cil/doc/examples/ex18.txt @@ -0,0 +1,20 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex18.c" +extern int f() ; +#line 1 "cilcode.tmp/ex18.c" +int main(void) +{ int tmp___0 ; + + { +#line 2 + tmp___0 = f(); + if (! tmp___0) { +#line 2 + tmp___0 = 4; + } +#line 2 + return (tmp___0); +} +} diff --git a/cil/doc/examples/ex19.txt b/cil/doc/examples/ex19.txt new file mode 100644 index 0000000..3b82868 --- /dev/null +++ b/cil/doc/examples/ex19.txt @@ -0,0 +1,42 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex19.c" +int main(void) +{ int x ; + int i ; + + { +#line 2 + i = 0; +#line 2 + while (i < 5) { +#line 3 + if (i == 5) { + goto __Cont; + } +#line 4 + if (i == 4) { +#line 4 + break; + } +#line 5 + i += 2; + __Cont: /* CIL Label */ +#line 2 + i ++; + } +#line 7 + while (x < 5) { +#line 8 + if (x == 3) { +#line 8 + continue; + } +#line 9 + x ++; + } +#line 11 + return (0); +} +} diff --git a/cil/doc/examples/ex2.txt b/cil/doc/examples/ex2.txt new file mode 100644 index 0000000..2031382 --- /dev/null +++ b/cil/doc/examples/ex2.txt @@ -0,0 +1,9 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex2.c" +struct __anonstruct_s_1 { + int x ; +}; +#line 1 "cilcode.tmp/ex2.c" +struct __anonstruct_s_1 s ; diff --git a/cil/doc/examples/ex20.txt b/cil/doc/examples/ex20.txt new file mode 100644 index 0000000..7a51db3 --- /dev/null +++ b/cil/doc/examples/ex20.txt @@ -0,0 +1,26 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex20.c" +int main(void) +{ int x ; + int y ; + int z ; + + { +#line 1 + x = 5; +#line 1 + y = x; +#line 2 + x ++; + L: +#line 2 + y -= x; +#line 2 + z = y; + goto L; +#line 3 + return (0); +} +} diff --git a/cil/doc/examples/ex21.txt b/cil/doc/examples/ex21.txt new file mode 100644 index 0000000..3f331e4 --- /dev/null +++ b/cil/doc/examples/ex21.txt @@ -0,0 +1,25 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex21.c" +int main(void) +{ int x ; + int y ; + int z ; + int *tmp ; + + { +#line 2 + if (x) { +#line 2 + tmp = & y; + } else { +#line 2 + tmp = & z; + } +#line 2 + x ++; +#line 2 + return (tmp - & x); +} +} diff --git a/cil/doc/examples/ex22.txt b/cil/doc/examples/ex22.txt new file mode 100644 index 0000000..2224e7c --- /dev/null +++ b/cil/doc/examples/ex22.txt @@ -0,0 +1,16 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 327 "/usr/include/stdio.h" +extern int printf(char const * __restrict __format , ...) ; +#line 7 "cilcode.tmp/ex22.c" +int main(void) +{ + + { +#line 9 + printf((char const * __restrict )"Hello world\n"); +#line 10 + return (0); +} +} diff --git a/cil/doc/examples/ex23.txt b/cil/doc/examples/ex23.txt new file mode 100644 index 0000000..d48a135 --- /dev/null +++ b/cil/doc/examples/ex23.txt @@ -0,0 +1,56 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex23.c" +int foo(int predicate ) +{ int x ; + + { +#line 2 + x = 0; +#line 4 + if (predicate == 0) { + goto switch_0_0; + } else { +#line 5 + if (predicate == 1) { + goto switch_0_1; + } else { +#line 6 + if (predicate == 2) { + goto switch_0_2; + } else { +#line 7 + if (predicate == 3) { + goto switch_0_3; + } else { + { + goto switch_0_default; +#line 3 + if (0) { + switch_0_0: /* CIL Label */ +#line 4 + return (111); + switch_0_1: /* CIL Label */ +#line 5 + x ++; + switch_0_2: /* CIL Label */ +#line 6 + return (x + 3); + switch_0_3: /* CIL Label */ + goto switch_0_break; + switch_0_default: /* CIL Label */ ; +#line 8 + return (222); + } else { + switch_0_break: /* CIL Label */ ; + } + } + } + } + } + } +#line 10 + return (333); +} +} diff --git a/cil/doc/examples/ex24.txt b/cil/doc/examples/ex24.txt new file mode 100644 index 0000000..587ce67 --- /dev/null +++ b/cil/doc/examples/ex24.txt @@ -0,0 +1,59 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +extern void * stackguard_get_ra(); +extern void stackguard_set_ra(void *new_ra); +/* You must provide an implementation for functions that get and set the + * return address. Such code is unfortunately architecture specific. + */ +struct stackguard_stack { + void * data; + struct stackguard_stack * next; +} * stackguard_stack; + +void stackguard_push(void *ra) { + void * old = stackguard_stack; + stackguard_stack = (struct stackguard_stack *) + malloc(sizeof(stackguard_stack)); + stackguard_stack->data = ra; + stackguard_stack->next = old; +} + +void * stackguard_pop() { + void * ret = stackguard_stack->data; + void * next = stackguard_stack->next; + free(stackguard_stack); + stackguard_stack->next = next; + return ret; +} +#line 3 "cilcode.tmp/ex24.c" +extern int ( /* missing proto */ scanf)() ; +#line 1 "cilcode.tmp/ex24.c" +int dangerous(void) +{ char array[10] ; + void *return_address ; + + { + return_address = (void *)stackguard_get_ra(); + stackguard_push(return_address); +#line 3 + scanf("%s", array); + { + return_address = (void *)stackguard_pop(); + stackguard_set_ra(return_address); +#line 4 + return (0); + } +} +} +#line 6 "cilcode.tmp/ex24.c" +int main(void) +{ int tmp ; + + { +#line 7 + tmp = dangerous(); +#line 7 + return (tmp); +} +} diff --git a/cil/doc/examples/ex25.txt b/cil/doc/examples/ex25.txt new file mode 100644 index 0000000..88f6902 --- /dev/null +++ b/cil/doc/examples/ex25.txt @@ -0,0 +1,40 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 3 "cilcode.tmp/ex25.c" +extern int ( /* missing proto */ scanf)() ; +#line 1 "cilcode.tmp/ex25.c" +struct dangerous_heapify { + char array[10] ; +}; +#line 1 "cilcode.tmp/ex25.c" +int dangerous(void) +{ struct dangerous_heapify *dangerous_heapify ; + int __cil_tmp3 ; + + { +#line 1 + dangerous_heapify = (struct dangerous_heapify *)malloc(sizeof(struct dangerous_heapify )); +#line 3 + scanf("%s", dangerous_heapify->array); + { +#line 4 + __cil_tmp3 = 0; +#line 4 + free(dangerous_heapify); +#line 4 + return (__cil_tmp3); + } +} +} +#line 6 "cilcode.tmp/ex25.c" +int main(void) +{ int tmp ; + + { +#line 7 + tmp = dangerous(); +#line 7 + return (tmp); +} +} diff --git a/cil/doc/examples/ex26.txt b/cil/doc/examples/ex26.txt new file mode 100644 index 0000000..8f5b171 --- /dev/null +++ b/cil/doc/examples/ex26.txt @@ -0,0 +1,29 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex26.c" +int foo(int predicate ) +{ int __retres ; + + { +#line 2 + if (predicate <= 0) { +#line 3 + __retres = 1; + goto return_label; + } else { +#line 5 + if (predicate > 5) { +#line 6 + __retres = 2; + goto return_label; + } +#line 7 + __retres = 3; + goto return_label; + } + return_label: /* CIL Label */ +#line 1 + return (__retres); +} +} diff --git a/cil/doc/examples/ex27.txt b/cil/doc/examples/ex27.txt new file mode 100644 index 0000000..6059113 --- /dev/null +++ b/cil/doc/examples/ex27.txt @@ -0,0 +1,51 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex27.c" +int foo(int x , int y ) +{ int unknown ; + + { +#line 3 + if (unknown) { +#line 4 + return (9); + } +#line 5 + return (x + 3); +} +} +#line 8 "cilcode.tmp/ex27.c" +int main(void) +{ int a ; + int b ; + int c ; + int tmp ; + int tmp___0 ; + + { + { +#line 10 + tmp = foo(5, 7); +#line 10 + tmp___0 = foo(6, 7); +#line 10 + a = tmp + tmp___0; +#line 11 + b = 4; +#line 12 + c = 16; + } + { + { +#line 16 + return (20); + } +#line 13 + if (0) { +#line 14 + return (b - c); + } + } +} +} diff --git a/cil/doc/examples/ex28.txt b/cil/doc/examples/ex28.txt new file mode 100644 index 0000000..098b144 --- /dev/null +++ b/cil/doc/examples/ex28.txt @@ -0,0 +1,24 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex28.c" +int main(void) +{ int ***three ; + int **two ; + int **mem_3 ; + int *mem_4 ; + int *mem_5 ; + + { +#line 4 + mem_3 = (*three); +#line 4 + mem_4 = (*mem_3); +#line 4 + mem_5 = (*two); +#line 4 + (*mem_4) = (*mem_5); +#line 5 + return (0); +} +} diff --git a/cil/doc/examples/ex29.txt b/cil/doc/examples/ex29.txt new file mode 100644 index 0000000..7df8f68 --- /dev/null +++ b/cil/doc/examples/ex29.txt @@ -0,0 +1,53 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 2 "cilcode.tmp/ex29.c" +struct mystruct { + int a ; + int b ; +}; +#line 1 "cilcode.tmp/ex29.c" +int main(void) +{ struct mystruct m ; + int local ; + int arr[3] ; + int *ptr ; + unsigned int __cil_tmp5 ; + unsigned int __cil_tmp6 ; + int __cil_tmp7 ; + unsigned int __cil_tmp8 ; + int *__cil_tmp9 ; + int __cil_tmp10 ; + unsigned int __cil_tmp11 ; + unsigned int __cil_tmp12 ; + unsigned int __cil_tmp13 ; + int m_b14 ; + int m_a15 ; + + { +#line 10 + ptr = & local; +#line 11 + __cil_tmp5 = 2 * 4U; +#line 11 + __cil_tmp6 = (unsigned int )(arr) + __cil_tmp5; +#line 11 + __cil_tmp7 = (*((int *)__cil_tmp6)); +#line 11 + __cil_tmp8 = (unsigned int )__cil_tmp7; +#line 11 + __cil_tmp9 = & local; +#line 11 + __cil_tmp10 = (*__cil_tmp9); +#line 11 + __cil_tmp11 = (unsigned int )__cil_tmp10; +#line 11 + __cil_tmp12 = __cil_tmp11 + 8U; +#line 11 + __cil_tmp13 = __cil_tmp12 + __cil_tmp8; +#line 11 + m_a15 = (int )__cil_tmp13; +#line 12 + return (m_a15); +} +} diff --git a/cil/doc/examples/ex3.txt b/cil/doc/examples/ex3.txt new file mode 100644 index 0000000..2ca8ac9 --- /dev/null +++ b/cil/doc/examples/ex3.txt @@ -0,0 +1,20 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex3.c" +union baz { + int x1 ; + double x2 ; +}; +#line 1 "cilcode.tmp/ex3.c" +struct bar { + union baz u1 ; + int y ; +}; +#line 1 "cilcode.tmp/ex3.c" +struct foo { + struct bar s1 ; + int z ; +}; +#line 1 "cilcode.tmp/ex3.c" +struct foo f ; diff --git a/cil/doc/examples/ex30.txt b/cil/doc/examples/ex30.txt new file mode 100644 index 0000000..729cfb0 --- /dev/null +++ b/cil/doc/examples/ex30.txt @@ -0,0 +1,12 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex30.c" +int main(void) +{ int x ; + + { +#line 2 + return (x == (x != 0)); +} +} diff --git a/cil/doc/examples/ex31.txt b/cil/doc/examples/ex31.txt new file mode 100644 index 0000000..ab7d471 --- /dev/null +++ b/cil/doc/examples/ex31.txt @@ -0,0 +1,12 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex31.c" +int main(void) +{ + + { +#line 1 + return ((int )((1U - sizeof(int )) >> 32)); +} +} diff --git a/cil/doc/examples/ex32.txt b/cil/doc/examples/ex32.txt new file mode 100644 index 0000000..f2b6b5b --- /dev/null +++ b/cil/doc/examples/ex32.txt @@ -0,0 +1,16 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex32.c" +int x = 5; +#line 2 "cilcode.tmp/ex32.c" +int f(void) +{ int x___0 ; + + { +#line 3 + x___0 = 3; +#line 6 + return (x); +} +} diff --git a/cil/doc/examples/ex33.txt b/cil/doc/examples/ex33.txt new file mode 100644 index 0000000..f73178f --- /dev/null +++ b/cil/doc/examples/ex33.txt @@ -0,0 +1,24 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex33.c" +int (*pf)(void) ; +#line 2 "cilcode.tmp/ex33.c" +int f(void) +{ + + { +#line 4 + pf = & f; +#line 5 + pf = & f; +#line 6 + ((*pf))(); +#line 7 + ((*pf))(); +#line 8 + f(); +#line 9 + return (0); +} +} diff --git a/cil/doc/examples/ex34.txt b/cil/doc/examples/ex34.txt new file mode 100644 index 0000000..494ca91 --- /dev/null +++ b/cil/doc/examples/ex34.txt @@ -0,0 +1,15 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex34.c" +struct __anonstruct_nested_2 { + int y ; + int z ; +}; +#line 1 "cilcode.tmp/ex34.c" +struct __anonstruct_i_1 { + int x ; + struct __anonstruct_nested_2 nested ; +}; +#line 1 "cilcode.tmp/ex34.c" +struct __anonstruct_i_1 i = {1, {2, 6}}; diff --git a/cil/doc/examples/ex35.txt b/cil/doc/examples/ex35.txt new file mode 100644 index 0000000..1af7447 --- /dev/null +++ b/cil/doc/examples/ex35.txt @@ -0,0 +1,32 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex35.c" +struct __anonstruct_T1_1 { + char *key ; + char *value ; +}; +#line 1 "cilcode.tmp/ex35.c" +typedef struct __anonstruct_T1_1 T1; +#line 7 "cilcode.tmp/ex35.c" +struct __anonstruct_T3_2 { + long type ; + char *value ; +}; +#line 7 "cilcode.tmp/ex35.c" +typedef struct __anonstruct_T3_2 T3; +#line 13 "cilcode.tmp/ex35.c" +struct __anonstruct_T3_2 __constr_expr_0 = {1L, (char *)1}; +#line 13 "cilcode.tmp/ex35.c" +T1 a[1] = { {(char *)"", (char *)(& __constr_expr_0)}}; +#line 20 "cilcode.tmp/ex35.c" +int main(void) +{ T3 *pt3 ; + + { +#line 21 + pt3 = (T3 *)a[0].value; +#line 22 + return ((int )pt3->value); +} +} diff --git a/cil/doc/examples/ex36.txt b/cil/doc/examples/ex36.txt new file mode 100644 index 0000000..adbcdaa --- /dev/null +++ b/cil/doc/examples/ex36.txt @@ -0,0 +1,20 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex36.c" +int main(void) +{ int __constr_expr_0[4] ; + + { +#line 1 + __constr_expr_0[0] = 1; +#line 1 + __constr_expr_0[1] = 2; +#line 1 + __constr_expr_0[2] = 3; +#line 1 + __constr_expr_0[3] = 4; +#line 1 + return (__constr_expr_0[1]); +} +} diff --git a/cil/doc/examples/ex37.txt b/cil/doc/examples/ex37.txt new file mode 100644 index 0000000..00d6ca4 --- /dev/null +++ b/cil/doc/examples/ex37.txt @@ -0,0 +1,14 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 3 "cilcode.tmp/ex37.c" +int foo(void) ; +#line 1 "cilcode.tmp/ex37.c" +int foo(void) +{ + + { +#line 5 + return (0); +} +} diff --git a/cil/doc/examples/ex38.txt b/cil/doc/examples/ex38.txt new file mode 100644 index 0000000..706e13d --- /dev/null +++ b/cil/doc/examples/ex38.txt @@ -0,0 +1,12 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex38.c" +unsigned long foo(void) +{ + + { +#line 2 + return (536870911UL); +} +} diff --git a/cil/doc/examples/ex39.txt b/cil/doc/examples/ex39.txt new file mode 100644 index 0000000..2c8c25f --- /dev/null +++ b/cil/doc/examples/ex39.txt @@ -0,0 +1,25 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex39.c" +int main(void) +{ int x ; + int y ; + int z ; + int *tmp ; + + { +#line 2 + if (x) { +#line 2 + tmp = & y; + } else { +#line 2 + tmp = & z; + } +#line 2 + x ++; +#line 2 + return (tmp - & x); +} +} diff --git a/cil/doc/examples/ex4.txt b/cil/doc/examples/ex4.txt new file mode 100644 index 0000000..00a22d3 --- /dev/null +++ b/cil/doc/examples/ex4.txt @@ -0,0 +1,16 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 2 "cilcode.tmp/ex4.c" +struct foo { + int x ; +}; +#line 1 "cilcode.tmp/ex4.c" +int main(void) +{ struct foo foo ; + + { +#line 8 + return (foo.x); +} +} diff --git a/cil/doc/examples/ex40.txt b/cil/doc/examples/ex40.txt new file mode 100644 index 0000000..c41496b --- /dev/null +++ b/cil/doc/examples/ex40.txt @@ -0,0 +1,20 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex40.c" +extern int f() ; +#line 1 "cilcode.tmp/ex40.c" +int main(void) +{ int tmp___0 ; + + { +#line 2 + tmp___0 = f(); + if (! tmp___0) { +#line 2 + tmp___0 = -1; + } +#line 2 + return (tmp___0); +} +} diff --git a/cil/doc/examples/ex41.txt b/cil/doc/examples/ex41.txt new file mode 100644 index 0000000..f1196f3 --- /dev/null +++ b/cil/doc/examples/ex41.txt @@ -0,0 +1,69 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex41.c" +static void *jtab[2] ; +#line 4 +static int doit(int x ) ; +#line 4 "cilcode.tmp/ex41.c" +static int jtab_init = 0; +#line 2 "cilcode.tmp/ex41.c" +static int doit(int x ) +{ unsigned int __compgoto ; + + { +#line 5 + if (! jtab_init) { +#line 6 + jtab[0] = (void *)0; +#line 7 + jtab[1] = (void *)1; +#line 8 + jtab_init = 1; + } +#line 10 + __compgoto = (unsigned int )jtab[x]; +#line 10 + switch (__compgoto) { + case 1: + goto lbl2; + case 0: + goto lbl1; + default: +#line 10 + (*((int *)0)) = 0; + } + lbl1: +#line 12 + return (0); + lbl2: +#line 14 + return (1); +} +} +#line 18 +extern int ( /* missing proto */ exit)() ; +#line 17 "cilcode.tmp/ex41.c" +int main(void) +{ int tmp ; + int tmp___0 ; + + { +#line 18 + tmp = doit(0); +#line 18 + if (tmp != 0) { +#line 18 + exit(1); + } +#line 19 + tmp___0 = doit(1); +#line 19 + if (tmp___0 != 1) { +#line 19 + exit(1); + } +#line 20 + exit(0); +} +} diff --git a/cil/doc/examples/ex42.txt b/cil/doc/examples/ex42.txt new file mode 100644 index 0000000..b0f40b8 --- /dev/null +++ b/cil/doc/examples/ex42.txt @@ -0,0 +1,22 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex42.c" +int main(void) +{ int tmp ; + + { + goto L; +#line 1 + if (0) { + L: +#line 1 + tmp = 1; + } else { +#line 1 + tmp = 0; + } +#line 1 + return (tmp); +} +} diff --git a/cil/doc/examples/ex43.txt b/cil/doc/examples/ex43.txt new file mode 100644 index 0000000..4104f79 --- /dev/null +++ b/cil/doc/examples/ex43.txt @@ -0,0 +1,46 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex43.c" +__inline static int foo__extinline(void) +{ + + { +#line 1 + return (1); +} +} +#line 2 "cilcode.tmp/ex43.c" +int firstuse(void) +{ int tmp ; + + { +#line 2 + tmp = foo__extinline(); +#line 2 + return (tmp); +} +} +#line 5 "cilcode.tmp/ex43.c" +int foo(void) +{ + + { +#line 5 + return (2); +} +} +#line 7 "cilcode.tmp/ex43.c" +int main(void) +{ int tmp ; + int tmp___0 ; + + { +#line 8 + tmp = foo(); +#line 8 + tmp___0 = firstuse(); +#line 8 + return (tmp + tmp___0); +} +} diff --git a/cil/doc/examples/ex44.txt b/cil/doc/examples/ex44.txt new file mode 100644 index 0000000..06f83ba --- /dev/null +++ b/cil/doc/examples/ex44.txt @@ -0,0 +1,31 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex44.c" +struct s { + int i1 ; + int i2 ; +}; +#line 1 "cilcode.tmp/ex44.c" +union u { + int i ; + struct s s ; +}; +#line 8 "cilcode.tmp/ex44.c" +union u x = {6}; +#line 10 "cilcode.tmp/ex44.c" +int main(void) +{ struct s y ; + union u z ; + + { +#line 11 + y.i1 = 1; +#line 11 + y.i2 = 2; +#line 12 + z.s = y; +#line 13 + return (0); +} +} diff --git a/cil/doc/examples/ex45.txt b/cil/doc/examples/ex45.txt new file mode 100644 index 0000000..aaafca3 --- /dev/null +++ b/cil/doc/examples/ex45.txt @@ -0,0 +1,11 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex45.c" +char i8 ; +#line 2 "cilcode.tmp/ex45.c" +short i16 ; +#line 3 "cilcode.tmp/ex45.c" +int i32 ; +#line 4 "cilcode.tmp/ex45.c" +long long i64 ; diff --git a/cil/doc/examples/ex46.txt b/cil/doc/examples/ex46.txt new file mode 100644 index 0000000..1f87ec2 --- /dev/null +++ b/cil/doc/examples/ex46.txt @@ -0,0 +1,23 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex46.c" +static int bar(int x , char y ) +{ + + { +#line 2 + return (x + (int )y); +} +} +#line 6 "cilcode.tmp/ex46.c" +int foo(int x , char y ) +{ int tmp ; + + { +#line 6 + tmp = bar(x, y); +#line 6 + return (tmp); +} +} diff --git a/cil/doc/examples/ex47.txt b/cil/doc/examples/ex47.txt new file mode 100644 index 0000000..cc5c306 --- /dev/null +++ b/cil/doc/examples/ex47.txt @@ -0,0 +1,28 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex47.c" +struct __anonstruct____missing_field_name_3 { + int u ; + int v ; +}; +#line 1 "cilcode.tmp/ex47.c" +struct __anonstruct____missing_field_name_2 { + int y ; + int z ; + struct __anonstruct____missing_field_name_3 __annonCompField1 ; +}; +#line 1 "cilcode.tmp/ex47.c" +struct __anonstruct_a_1 { + int x ; + struct __anonstruct____missing_field_name_2 __annonCompField2 ; +}; +#line 1 "cilcode.tmp/ex47.c" +int main(void) +{ struct __anonstruct_a_1 a ; + + { +#line 10 + return ((((a.x + a.__annonCompField2.y) + a.__annonCompField2.z) + a.__annonCompField2.__annonCompField1.u) + a.__annonCompField2.__annonCompField1.v); +} +} diff --git a/cil/doc/examples/ex5.txt b/cil/doc/examples/ex5.txt new file mode 100644 index 0000000..d750bb5 --- /dev/null +++ b/cil/doc/examples/ex5.txt @@ -0,0 +1,27 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex5.c" +int f(double x ) ; +#line 3 +int g(double x ) ; +#line 2 "cilcode.tmp/ex5.c" +int f(double x ) +{ int tmp ; + + { +#line 3 + tmp = g(x); +#line 3 + return (tmp); +} +} +#line 5 "cilcode.tmp/ex5.c" +int g(double x ) +{ + + { +#line 6 + return ((int )x); +} +} diff --git a/cil/doc/examples/ex6.txt b/cil/doc/examples/ex6.txt new file mode 100644 index 0000000..c33eb9e --- /dev/null +++ b/cil/doc/examples/ex6.txt @@ -0,0 +1,7 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex6.c" +int a1[3] = { 1, 2, 3}; +#line 2 "cilcode.tmp/ex6.c" +int a2[8] ; diff --git a/cil/doc/examples/ex7.txt b/cil/doc/examples/ex7.txt new file mode 100644 index 0000000..55434c7 --- /dev/null +++ b/cil/doc/examples/ex7.txt @@ -0,0 +1,22 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 2 "cilcode.tmp/ex7.c" +enum __anonenum_x_1 { + FIVE = 5, + SIX = 6, + SEVEN = 7, + FOUR = 4, + EIGHT = 8 +} ; +#line 1 "cilcode.tmp/ex7.c" +int main(void) +{ enum __anonenum_x_1 x ; + + { +#line 2 + x = 5; +#line 8 + return ((int )x); +} +} diff --git a/cil/doc/examples/ex8.txt b/cil/doc/examples/ex8.txt new file mode 100644 index 0000000..323a41e --- /dev/null +++ b/cil/doc/examples/ex8.txt @@ -0,0 +1,13 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 2 "cilcode.tmp/ex8.c" +struct foo { + int x ; + int y ; +}; +#line 1 "cilcode.tmp/ex8.c" +int a1[5] = { 1, 2, 3, 0, + 0}; +#line 2 "cilcode.tmp/ex8.c" +struct foo s1 = {4, 0}; diff --git a/cil/doc/examples/ex9.txt b/cil/doc/examples/ex9.txt new file mode 100644 index 0000000..22e976c --- /dev/null +++ b/cil/doc/examples/ex9.txt @@ -0,0 +1,16 @@ +/* Generated by CIL v. 1.3.5 */ +/* print_CIL_Input is true */ + +#line 1 "cilcode.tmp/ex9.c" +struct inner { + int z ; +}; +#line 1 "cilcode.tmp/ex9.c" +struct foo { + int x ; + int y ; + int a[5] ; + struct inner inner ; +}; +#line 1 "cilcode.tmp/ex9.c" +struct foo s = {0, 8, {0, 5, 5, 4, 0}, {3}}; diff --git a/cil/doc/ext.html b/cil/doc/ext.html new file mode 100644 index 0000000..532e225 --- /dev/null +++ b/cil/doc/ext.html @@ -0,0 +1,506 @@ + + + + + + + + + + + + + +Library of CIL Modules + + + +Previous +Up +Next +
+ +

8  Library of CIL Modules


+
+We are developing a suite of modules that use CIL for program analyses and +transformations that we have found useful. You can use these modules directly +on your code, or generally as inspiration for writing similar modules. A +particularly big and complex application written on top of CIL is CCured +(../ccured/index.html).
+
+ +

8.1  Control-Flow Graphs

+The Cil.stmt datatype includes fields for intraprocedural +control-flow information: the predecessor and successor statements of +the current statement. This information is not computed by default. +If you want to use the control-flow graph, or any of the extensions in +this section that require it, you have to explicitly ask CIL to +compute the CFG.
+
+ +

8.1.1  The CFG module (new in CIL 1.3.5)

+The best way to compute the CFG is with the CFG module. Just invoke +Cfg.computeFileCFG on your file. The Cfg API +describes the rest of actions you can take with this module, including +computing the CFG for one function at a time, or printing the CFG in +dot form.
+
+ +

8.1.2  Simplified control flow

+CIL can reduce high-level C control-flow constructs like switch and +continue to lower-level gotos. This completely eliminates some +possible classes of statements from the program and may make the result +easier to analyze (e.g., it simplifies data-flow analysis).
+
+You can invoke this transformation on the command line with +--domakeCFG or programatically with Cil.prepareCFG. +After calling Cil.prepareCFG, you can use Cil.computeCFGInfo +to compute the CFG information and find the successor and predecessor +of each statement.
+
+For a concrete example, you can see how cilly --domakeCFG +transforms the following code (note the fall-through in case 1): +

+  int foo (int predicate) {
+    int x = 0;
+    switch (predicate) {
+      case 0: return 111;
+      case 1: x = x + 1;
+      case 2: return (x+3);
+      case 3: break;
+      default: return 222;
+    }
+    return 333;
+  }
+
+See the CIL output for this +code fragment
+
+ +

8.2  Data flow analysis framework

+The Dataflow module (click for the ocamldoc) contains a +parameterized framework for forward and backward data flow +analyses. You provide the transfer functions and this module does the +analysis. You must compute control-flow information (Section 8.1) +before invoking the Dataflow module.
+
+ +

8.3  Dominators

+The module Dominators contains the computation of immediate + dominators. It uses the Dataflow module.
+
+ +

8.4  Points-to Analysis

+The module ptranal.ml contains two interprocedural points-to +analyses for CIL: Olf and Golf. Olf is the default. +(Switching from olf.ml to golf.ml requires a change in +Ptranal and a recompiling cilly.)
+
+The analyses have the following characteristics: +
  • +Not based on C types (inferred pointer relationships are sound + despite most kinds of C casts) +
  • One level of subtyping +
  • One level of context sensitivity (Golf only) +
  • Monomorphic type structures +
  • Field insensitive (fields of structs are conflated) +
  • Demand-driven (points-to queries are solved on demand) +
  • Handle function pointers +
+The analysis itself is factored into two components: Ptranal, +which walks over the CIL file and generates constraints, and Olf +or Golf, which solve the constraints. The analysis is invoked +with the function Ptranal.analyze_file: Cil.file -> + unit. This function builds the points-to graph for the CIL file +and stores it internally. There is currently no facility for clearing +internal state, so Ptranal.analyze_file should only be called +once.
+
+The constructed points-to graph supports several kinds of queries, +including alias queries (may two expressions be aliased?) and +points-to queries (to what set of locations may an expression point?).
+
+The main interface with the alias analysis is as follows: +
  • +Ptranal.may_alias: Cil.exp -> Cil.exp -> bool. If + true, the two expressions may have the same value. +
  • Ptranal.resolve_lval: Cil.lval -> (Cil.varinfo + list). Returns the list of variables to which the given + left-hand value may point. +
  • Ptranal.resolve_exp: Cil.exp -> (Cil.varinfo list). + Returns the list of variables to which the given expression may + point. +
  • Ptranal.resolve_funptr: Cil.exp -> (Cil.fundec + list). Returns the list of functions to which the given + expression may point. +
+The precision of the analysis can be customized by changing the values +of several flags: +
  • +Ptranal.no_sub: bool ref. + If true, subtyping is disabled. Associated commandline option: + --ptr_unify. +
  • Ptranal.analyze_mono: bool ref. + (Golf only) If true, context sensitivity is disabled and the + analysis is effectively monomorphic. Commandline option: + --ptr_mono. +
  • Ptranal.smart_aliases: bool ref. + (Golf only) If true, “smart” disambiguation of aliases is + enabled. Otherwise, aliases are computed by intersecting points-to + sets. This is an experimental feature. +
  • Ptranal.model_strings: bool ref. + Make the alias analysis model string constants by treating them as + pointers to chars. Commandline option: --ptr_model_strings +
  • Ptranal.conservative_undefineds: bool ref. + Make the most pessimistic assumptions about globals if an undefined + function is present. Such a function can write to every global + variable. Commandline option: --ptr_conservative +
+In practice, the best precision/efficiency tradeoff is achieved by +setting Ptranal.no_sub to false, Ptranal.analyze_mono to +true, and Ptranal.smart_aliases to false. These are the +default values of the flags.
+
+There are also a few flags that can be used to inspect or serialize +the results of the analysis. +
  • +Ptranal.debug_may_aliases. + Print the may-alias relationship of each pair of expressions in the + program. Commandline option: --ptr_may_aliases. +
  • Ptranal.print_constraints: bool ref. + If true, the analysis will print each constraint as it is + generated. +
  • Ptranal.print_types: bool ref. + If true, the analysis will print the inferred type of each + variable in the program.
    +
    +If Ptranal.analyze_mono and Ptranal.no_sub are both + true, this output is sufficient to reconstruct the points-to + graph. One nice feature is that there is a pretty printer for + recursive types, so the print routine does not loop. +
  • Ptranal.compute_results: bool ref. + If true, the analysis will print out the points-to set of each + variable in the program. This will essentially serialize the + points-to graph. +
+ +

8.5  StackGuard

+The module heapify.ml contains a transformation similar to the one +described in “StackGuard: Automatic Adaptive Detection and Prevention of +Buffer-Overflow Attacks”, Proceedings of the 7th USENIX Security +Conference. In essence it modifies the program to maintain a separate +stack for return addresses. Even if a buffer overrun attack occurs the +actual correct return address will be taken from the special stack.
+
+Although it does work, this CIL module is provided mainly as an example of +how to perform a simple source-to-source program analysis and +transformation. As an optimization only functions that contain a dangerous +local array make use of the special return address stack.
+
+For a concrete example, you can see how cilly --dostackGuard +transforms the following dangerous code: +

+  int dangerous() {
+    char array[10];
+    scanf("%s",array); // possible buffer overrun!
+  }
+
+  int main () {
+    return dangerous();
+  }
+
+See the CIL output for this +code fragment
+
+ +

8.6  Heapify

+The module heapify.ml also contains a transformation that moves all +dangerous local arrays to the heap. This also prevents a number of buffer +overruns.
+
+For a concrete example, you can see how cilly --doheapify +transforms the following dangerous code: +

+  int dangerous() {
+    char array[10];
+    scanf("%s",array); // possible buffer overrun!
+  }
+
+  int main () {
+    return dangerous();
+  }
+
+See the CIL output for this +code fragment
+
+ +

8.7  One Return

+The module oneret.ml contains a transformation the ensures that all +function bodies have at most one return statement. This simplifies a number +of analyses by providing a canonical exit-point.
+
+For a concrete example, you can see how cilly --dooneRet +transforms the following code: +

+  int foo (int predicate) {
+    if (predicate <= 0) {
+      return 1;
+    } else {
+      if (predicate > 5)
+        return 2;
+      return 3;
+    }
+  }
+
+See the CIL output for this +code fragment
+
+ +

8.8  Partial Evaluation and Constant Folding

+The partial.ml module provides a simple interprocedural partial +evaluation and constant folding data-flow analysis and transformation. This +transformation requires the --domakeCFG option.
+
+For a concrete example, you can see how cilly --domakeCFG --dopartial +transforms the following code (note the eliminated if branch and the +partial optimization of foo): +

+  int foo(int x, int y) {
+    int unknown;
+    if (unknown)
+      return y+2;     
+    return x+3;      
+  }
+
+  int main () {
+    int a,b,c;
+    a = foo(5,7) + foo(6,7);
+    b = 4;
+    c = b * b;      
+    if (b > c)     
+      return b-c;
+    else
+      return b+c; 
+  }
+
+See the CIL output for this +code fragment
+
+ +

8.9  Reaching Definitions

+The reachingdefs.ml module uses the dataflow framework and CFG +information to calculate the definitions that reach each +statement. After computing the CFG (Section 8.1) and calling +computeRDs on a +function declaration, ReachingDef.stmtStartData will contain a +mapping from statement IDs to data about which definitions reach each +statement. In particular, it is a mapping from statement IDs to a +triple the first two members of which are used internally. The third +member is a mapping from variable IDs to Sets of integer options. If +the set contains Some(i), then the definition of that variable +with ID i reaches that statement. If the set contains None, +then there is a path to that statement on which there is no definition +of that variable. Also, if the variable ID is unmapped at a +statement, then no definition of that variable reaches that statement.
+
+To summarize, reachingdefs.ml has the following interface: +
  • +computeRDs – Computes reaching definitions. Requires that +CFG information has already been computed for each statement. +
  • ReachingDef.stmtStartData – contains reaching +definition data after computeRDs is called. +
  • ReachingDef.defIdStmtHash – Contains a mapping +from definition IDs to the ID of the statement in which +the definition occurs. +
  • getRDs – Takes a statement ID and returns +reaching definition data for that statement. +
  • instrRDs – Takes a list of instructions and the +definitions that reach the first instruction, and for +each instruction calculates the definitions that reach +either into or out of that instruction. +
  • rdVisitorClass – A subclass of nopCilVisitor that +can be extended such that the current reaching definition +data is available when expressions are visited through +the get_cur_iosh method of the class. +
+ +

8.10  Available Expressions

+The availexps.ml module uses the dataflow framework and CFG +information to calculate something similar to a traditional available +expressions analysis. After computeAEs is called following a CFG +calculation (Section 8.1), AvailableExps.stmtStartData will +contain a mapping +from statement IDs to data about what expressions are available at +that statement. The data for each statement is a mapping for each +variable ID to the whole expression available at that point(in the +traditional sense) which the variable was last defined to be. So, +this differs from a traditional available expressions analysis in that +only whole expressions from a variable definition are considered rather +than all expressions.
+
+The interface is as follows: +
  • +computeAEs – Computes available expressions. Requires +that CFG information has already been comptued for each statement. +
  • AvailableExps.stmtStartData – Contains available +expressions data for each statement after computeAEs has been +called. +
  • getAEs – Takes a statement ID and returns +available expression data for that statement. +
  • instrAEs – Takes a list of instructions and +the availalbe expressions at the first instruction, and +for each instruction calculates the expressions available +on entering or exiting each instruction. +
  • aeVisitorClass – A subclass of nopCilVisitor that +can be extended such that the current available expressions +data is available when expressions are visited through the +get_cur_eh method of the class. +
+ +

8.11  Liveness Analysis

+The liveness.ml module uses the dataflow framework and +CFG information to calculate which variables are live at +each program point. After computeLiveness is called +following a CFG calculation (Section 8.1), LiveFlow.stmtStartData will +contain a mapping for each statement ID to a set of varinfos +for varialbes live at that program point.
+
+The interface is as follows: +
  • +computeLiveness – Computes live variables. Requires +that CFG information has already been computed for each statement. +
  • LiveFlow.stmtStartData – Contains live variable data +for each statement after computeLiveness has been called. +
+Also included in this module is a command line interface that +will cause liveness data to be printed to standard out for +a particular function or label. +
  • +–doliveness – Instructs cilly to comptue liveness +information and to print on standard out the variables live +at the points specified by –live_func and live_label. +If both are ommitted, then nothing is printed. +
  • –live_func – The name of the function whose +liveness data is of interest. If –live_label is ommitted, +then data for each statement is printed. +
  • –live_label – The name of the label at which +the liveness data will be printed. +
+ +

8.12  Dead Code Elimination

+The module deadcodeelim.ml uses the reaching definitions +analysis to eliminate assignment instructions whose results +are not used. The interface is as follows: +
  • +elim_dead_code – Performs dead code elimination +on a function. Requires that CFG information has already +been computed (Section 8.1). +
  • dce – Performs dead code elimination on an +entire file. Requires that CFG information has already +been computed. +
+ +

8.13  Simple Memory Operations

+The simplemem.ml module allows CIL lvalues that contain memory +accesses to be even futher simplified via the introduction of +well-typed temporaries. After this transformation all lvalues involve +at most one memory reference.
+
+For a concrete example, you can see how cilly --dosimpleMem +transforms the following code: +

+  int main () {
+    int ***three;
+    int **two;
+    ***three = **two; 
+  } 
+
+See the CIL output for this +code fragment
+
+ +

8.14  Simple Three-Address Code

+The simplify.ml module further reduces the complexity of program +expressions and gives you a form of three-address code. After this +transformation all expressions will adhere to the following grammar: +
+ basic::=
+    Const _ 
+    Addrof(Var v, NoOffset)
+    StartOf(Var v, NoOffset)
+    Lval(Var v, off), where v is a variable whose address is not taken
+                      and off contains only "basic"
+
+ exp::=
+    basic
+    Lval(Mem basic, NoOffset)
+    BinOp(bop, basic, basic)
+    UnOp(uop, basic)
+    CastE(t, basic)
+   
+ lval ::= 
+    Mem basic, NoOffset
+    Var v, off, where v is a variable whose address is not taken and off
+                contains only "basic"
+
In addition, all sizeof and alignof forms are turned into +constants. Accesses to arrays and variables whose address is taken are +turned into "Mem" accesses. All field and index computations are turned +into address arithmetic.
+
+For a concrete example, you can see how cilly --dosimplify +transforms the following code: +

+  int main() {
+    struct mystruct {
+      int a;
+      int b;
+    } m;
+    int local;
+    int arr[3];
+    int *ptr;
+
+    ptr = &local;
+    m.a = local + sizeof(m) + arr[2];
+    return m.a; 
+  } 
+
+See the CIL output for this +code fragment
+
+ +

8.15  Converting C to C++

+The module canonicalize.ml performs several transformations to correct +differences between C and C++, so that the output is (hopefully) valid +C++ code. This may be incomplete — certain fixes which are necessary +for some programs are not yet implemented.
+
+Using the --doCanonicalize option with CIL will perform the +following changes to your program: +
  1. +Any variables that use C++ keywords as identifiers are renamed. +
  2. C allows global variables to have multiple declarations and + multiple (equivalent) definitions. This transformation removes + all but one declaration and all but one definition. +
  3. __inline is #defined to inline, and __restrict + is #defined to nothing. +
  4. C allows function pointers with no specified arguments to be used on + any argument list. To make C++ accept this code, we insert a cast + from the function pointer to a type that matches the arguments. Of + course, this does nothing to guarantee that the pointer actually has + that type. +
  5. Makes casts from int to enum types explicit. (CIL changes enum + constants to int constants, but doesn't use a cast.) +
+
+Previous +Up +Next + + diff --git a/cil/doc/header.html b/cil/doc/header.html new file mode 100644 index 0000000..cfedee9 --- /dev/null +++ b/cil/doc/header.html @@ -0,0 +1,18 @@ + + + + + + + +CIL Documentation (v. 1.3.5) + + + + + +

CIL - Infrastructure for C Program Analysis and Transformation (v. 1.3.5)

+ + + + diff --git a/cil/doc/index.html b/cil/doc/index.html new file mode 100644 index 0000000..77ec160 --- /dev/null +++ b/cil/doc/index.html @@ -0,0 +1,26 @@ + + + + + + +CIL Documentation (v. 1.3.5) + + + + + + + + + + <body> + + <p>This page uses frames, but your browser doesn't support them.</p> + + </body> + + + + \ No newline at end of file diff --git a/cil/doc/merger.html b/cil/doc/merger.html new file mode 100644 index 0000000..636dd2a --- /dev/null +++ b/cil/doc/merger.html @@ -0,0 +1,167 @@ + + + + + + + + + + + + + +Using the merger + + + +Previous +Up +Next +
+ +

13  Using the merger


+
+There are many program analyses that are more effective when +done on the whole program.
+
+The merger is a tool that combines all of the C source files in a project +into a single C file. There are two tasks that a merger must perform: +
  1. +Detect what are all the sources that make a project and with what +compiler arguments they are compiled.
    +
    +
  2. Merge all of the source files into a single file. +
+For the first task the merger impersonates a compiler and a linker (both a +GCC and a Microsoft Visual C mode are supported) and it expects to be invoked +(from a build script or a Makefile) on all sources of the project. When +invoked to compile a source the merger just preprocesses the source and saves +the result using the name of the requested object file. By preprocessing at +this time the merger is able to take into account variations in the command +line arguments that affect preprocessing of different source files.
+
+When the merger is invoked to link a number of object files it collects the +preprocessed sources that were stored with the names of the object files, and +invokes the merger proper. Note that arguments that affect the compilation or +linking must be the same for all source files.
+
+For the second task, the merger essentially concatenates the preprocessed +sources with care to rename conflicting file-local declarations (we call this +process alpha-conversion of a file). The merger also attempts to remove +duplicate global declarations and definitions. Specifically the following +actions are taken: +
  • +File-scope names (static globals, names of types defined with +typedef, and structure/union/enumeration tags) are given new names if they +conflict with declarations from previously processed sources. The new name is +formed by appending the suffix ___n, where n is a unique integer +identifier. Then the new names are applied to their occurrences in the file.
    +
    +
  • Non-static declarations and definitions of globals are never renamed. +But we try to remove duplicate ones. Equality of globals is detected by +comparing the printed form of the global (ignoring the line number directives) +after the body has been alpha-converted. This process is intended to remove +those declarations (e.g. function prototypes) that originate from the same +include file. Similarly, we try to eliminate duplicate definitions of +inline functions, since these occasionally appear in include files.
    +
    +
  • The types of all global declarations with the same name from all files +are compared for type isomorphism. During this process, the merger detects all +those isomorphisms between structures and type definitions that are required for the merged program to be legal. Such structure tags and +typenames are coalesced and given the same name.
    +
    +
  • Besides the structure tags and type names that are required to be +isomorphic, the merger also tries to coalesce definitions of structures and +types with the same name from different file. However, in this case the merger +will not give an error if such definitions are not isomorphic; it will just +use different names for them.
    +
    +
  • In rare situations, it can happen that a file-local global in +encountered first and it is not renamed, only to discover later when +processing another file that there is an external symbol with the same name. +In this case, a second pass is made over the merged file to rename the +file-local symbol. +
+Here is an example of using the merger:
+
+The contents of file1.c is: +

+struct foo; // Forward declaration
+extern struct foo *global;
+
+The contents of file2.c is: +

+struct bar {
+ int x;
+ struct bar *next;
+};
+extern struct bar *global;
+struct foo {
+ int y;
+};
+extern struct foo another;
+void main() {
+}
+
+There are several ways in which one might create an executable from these +files: +
  • +
    +gcc file1.c file2.c -o a.out
+

    +
    +
  • +gcc -c file1.c -o file1.o
+gcc -c file2.c -o file2.o
+ld file1.o file2.o -o a.out
+

    +
    +
  • +gcc -c file1.c -o file1.o
+gcc -c file2.c -o file2.o
+ar r libfile2.a file2.o
+gcc file1.o libfile2.a -o a.out
+

    +
    +
  • +gcc -c file1.c -o file1.o
+gcc -c file2.c -o file2.o
+ar r libfile2.a file2.o
+gcc file1.o -lfile2 -o a.out
+
+In each of the cases above you must replace all occurrences of gcc and +ld with cilly --merge, and all occurrences of ar with cilly +--merge --mode=AR. It is very important that the --merge flag be used +throughout the build process. If you want to see the merged source file you +must also pass the --keepmerged flag to the linking phase.
+
+The result of merging file1.c and file2.c is: +

+// from file1.c
+struct foo; // Forward declaration
+extern struct foo *global;
+
+// from file2.c
+struct foo {
+ int x;
+ struct foo *next;
+};
+struct foo___1 {
+ int y;
+};
+extern struct foo___1 another;
+
+
+Previous +Up +Next + + diff --git a/cil/doc/next_motif.gif b/cil/doc/next_motif.gif new file mode 100644 index 0000000..3f84bac Binary files /dev/null and b/cil/doc/next_motif.gif differ diff --git a/cil/doc/patcher.html b/cil/doc/patcher.html new file mode 100644 index 0000000..2c727e2 --- /dev/null +++ b/cil/doc/patcher.html @@ -0,0 +1,126 @@ + + + + + + + + + + + + + +Using the patcher + + + +Previous +Up +Next +
+ +

14  Using the patcher


+
+Occasionally we have needed to modify slightly the standard include files. +So, we developed a simple mechanism that allows us to create modified copies +of the include files and use them instead of the standard ones. For this +purpose we specify a patch file and we run a program caller Patcher which +makes modified copies of include files and applies the patch.
+
+The patcher is invoked as follows: +
+bin/patcher [options]
+
+Options:
+  --help       Prints this help message
+  --verbose    Prints a lot of information about what is being done
+  --mode=xxx   What tool to emulate: 
+                GNUCC     - GNU CC
+                MSVC      - MS VC cl compiler
+
+  --dest=xxx   The destination directory. Will make one if it does not exist
+  --patch=xxx  Patch file (can be specified multiple times)
+  --ppargs=xxx An argument to be passed to the preprocessor (can be specified
+               multiple times)
+
+  --ufile=xxx  A user-include file to be patched (treated as \#include "xxx")
+  --sfile=xxx  A system-include file to be patched (treated as \#include <xxx>)
+ 
+  --clean       Remove all files in the destination directory
+  --dumpversion Print the version name used for the current compiler
+
+ All of the other arguments are passed to the preprocessor. You should pass
+ enough arguments (e.g., include directories) so that the patcher can find the
+ right include files to be patched.
+
+ Based on the given mode and the current version of the compiler (which +the patcher can print when given the dumpversion argument) the patcher +will create a subdirectory of the dest directory (say /usr/home/necula/cil/include), such as: +
+/usr/home/necula/cil/include/gcc_2.95.3-5
+
+ In that file the patcher will copy the modified versions of the include files +specified with the ufile and sfile options. Each of these options can +be specified multiple times.
+
+The patch file (specified with the patch option) has a format inspired by +the Unix patch tool. The file has the following grammar: +
+<<< flags
+patterns
+===
+replacement
+>>>
+
+ The flags are a comma separated, case-sensitive, sequence of keywords or +keyword = value. The following flags are supported: +
  • +file=foo.h - will only apply the patch on files whose name is + foo.h. +
  • optional - this means that it is Ok if the current patch does not +match any of the processed files. +
  • group=foo - will add this patch to the named group. If this is not +specified then a unique group is created to contain just the current patch. +When all files specified in the command line have been patched, an error +message is generated for all groups for whom no member patch was used. We use +this mechanism to receive notice when the patch triggers are out-dated with +respect to the new include files. +
  • system=sysname - will only consider this pattern on a given +operating system. The “sysname” is reported by the “$Ô” variable in +Perl, except that Windows is always considered to have sysname +“cygwin.” For Linux use “linux” (capitalization matters). +
  • ateof - In this case the patterns are ignored and the replacement +text is placed at the end of the patched file. Use the file flag if you +want to restrict the files in which this replacement is performed. +
  • atsof - The patterns are ignored and the replacement text is placed +at the start of the patched file. Uf the file flag to restrict the +application of this patch to a certain file. +
  • disabled - Use this flag if you want to disable the pattern. +
+The patterns can consist of several groups of lines separated by the ||| +marker. Each of these group of lines is a multi-line pattern that if found in +the file will be replaced with the text given at the end of the block.
+
+The matching is space-insensitive.
+
+All of the markers <<<, |||, === and >>> must appear at the +beginning of a line but they can be followed by arbitrary text (which is +ignored).
+
+The replacement text can contain the special keyword @__pattern__@, +which is substituted with the pattern that matched.
+
+
+Previous +Up +Next + + diff --git a/cil/doc/previous_motif.gif b/cil/doc/previous_motif.gif new file mode 100644 index 0000000..8c8a3e6 Binary files /dev/null and b/cil/doc/previous_motif.gif differ diff --git a/cil/install-sh b/cil/install-sh new file mode 100644 index 0000000..e9de238 --- /dev/null +++ b/cil/install-sh @@ -0,0 +1,251 @@ +#!/bin/sh +# +# install - install a program, script, or datafile +# This comes from X11R5 (mit/util/scripts/install.sh). +# +# Copyright 1991 by the Massachusetts Institute of Technology +# +# Permission to use, copy, modify, distribute, and sell this software and its +# documentation for any purpose is hereby granted without fee, provided that +# the above copyright notice appear in all copies and that both that +# copyright notice and this permission notice appear in supporting +# documentation, and that the name of M.I.T. not be used in advertising or +# publicity pertaining to distribution of the software without specific, +# written prior permission. M.I.T. makes no representations about the +# suitability of this software for any purpose. It is provided "as is" +# without express or implied warranty. +# +# Calling this script install-sh is preferred over install.sh, to prevent +# `make' implicit rules from creating a file called install from it +# when there is no Makefile. +# +# This script is compatible with the BSD install script, but was written +# from scratch. It can only install one file at a time, a restriction +# shared with many OS's install programs. + + +# set DOITPROG to echo to test this script + +# Don't use :- since 4.3BSD and earlier shells don't like it. +doit="${DOITPROG-}" + + +# put in absolute paths if you don't have them in your path; or use env. vars. + +mvprog="${MVPROG-mv}" +cpprog="${CPPROG-cp}" +chmodprog="${CHMODPROG-chmod}" +chownprog="${CHOWNPROG-chown}" +chgrpprog="${CHGRPPROG-chgrp}" +stripprog="${STRIPPROG-strip}" +rmprog="${RMPROG-rm}" +mkdirprog="${MKDIRPROG-mkdir}" + +transformbasename="" +transform_arg="" +instcmd="$mvprog" +chmodcmd="$chmodprog 0755" +chowncmd="" +chgrpcmd="" +stripcmd="" +rmcmd="$rmprog -f" +mvcmd="$mvprog" +src="" +dst="" +dir_arg="" + +while [ x"$1" != x ]; do + case $1 in + -c) instcmd="$cpprog" + shift + continue;; + + -d) dir_arg=true + shift + continue;; + + -m) chmodcmd="$chmodprog $2" + shift + shift + continue;; + + -o) chowncmd="$chownprog $2" + shift + shift + continue;; + + -g) chgrpcmd="$chgrpprog $2" + shift + shift + continue;; + + -s) stripcmd="$stripprog" + shift + continue;; + + -t=*) transformarg=`echo $1 | sed 's/-t=//'` + shift + continue;; + + -b=*) transformbasename=`echo $1 | sed 's/-b=//'` + shift + continue;; + + *) if [ x"$src" = x ] + then + src=$1 + else + # this colon is to work around a 386BSD /bin/sh bug + : + dst=$1 + fi + shift + continue;; + esac +done + +if [ x"$src" = x ] +then + echo "install: no input file specified" + exit 1 +else + true +fi + +if [ x"$dir_arg" != x ]; then + dst=$src + src="" + + if [ -d $dst ]; then + instcmd=: + chmodcmd="" + else + instcmd=mkdir + fi +else + +# Waiting for this to be detected by the "$instcmd $src $dsttmp" command +# might cause directories to be created, which would be especially bad +# if $src (and thus $dsttmp) contains '*'. + + if [ -f $src -o -d $src ] + then + true + else + echo "install: $src does not exist" + exit 1 + fi + + if [ x"$dst" = x ] + then + echo "install: no destination specified" + exit 1 + else + true + fi + +# If destination is a directory, append the input filename; if your system +# does not like double slashes in filenames, you may need to add some logic + + if [ -d $dst ] + then + dst="$dst"/`basename $src` + else + true + fi +fi + +## this sed command emulates the dirname command +dstdir=`echo $dst | sed -e 's,[^/]*$,,;s,/$,,;s,^$,.,'` + +# Make sure that the destination directory exists. +# this part is taken from Noah Friedman's mkinstalldirs script + +# Skip lots of stat calls in the usual case. +if [ ! -d "$dstdir" ]; then +defaultIFS=' +' +IFS="${IFS-${defaultIFS}}" + +oIFS="${IFS}" +# Some sh's can't handle IFS=/ for some reason. +IFS='%' +set - `echo ${dstdir} | sed -e 's@/@%@g' -e 's@^%@/@'` +IFS="${oIFS}" + +pathcomp='' + +while [ $# -ne 0 ] ; do + pathcomp="${pathcomp}${1}" + shift + + if [ ! -d "${pathcomp}" ] ; + then + $mkdirprog "${pathcomp}" + else + true + fi + + pathcomp="${pathcomp}/" +done +fi + +if [ x"$dir_arg" != x ] +then + $doit $instcmd $dst && + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dst; else true ; fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dst; else true ; fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dst; else true ; fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dst; else true ; fi +else + +# If we're going to rename the final executable, determine the name now. + + if [ x"$transformarg" = x ] + then + dstfile=`basename $dst` + else + dstfile=`basename $dst $transformbasename | + sed $transformarg`$transformbasename + fi + +# don't allow the sed command to completely eliminate the filename + + if [ x"$dstfile" = x ] + then + dstfile=`basename $dst` + else + true + fi + +# Make a temp file name in the proper directory. + + dsttmp=$dstdir/#inst.$$# + +# Move or copy the file name to the temp name + + $doit $instcmd $src $dsttmp && + + trap "rm -f ${dsttmp}" 0 && + +# and set any options; do chmod last to preserve setuid bits + +# If any of these fail, we abort the whole thing. If we want to +# ignore errors from any of these, just make sure not to ignore +# errors from the above "$doit $instcmd $src $dsttmp" command. + + if [ x"$chowncmd" != x ]; then $doit $chowncmd $dsttmp; else true;fi && + if [ x"$chgrpcmd" != x ]; then $doit $chgrpcmd $dsttmp; else true;fi && + if [ x"$stripcmd" != x ]; then $doit $stripcmd $dsttmp; else true;fi && + if [ x"$chmodcmd" != x ]; then $doit $chmodcmd $dsttmp; else true;fi && + +# Now rename the file to the real destination. + + $doit $rmcmd -f $dstdir/$dstfile && + $doit $mvcmd $dsttmp $dstdir/$dstfile + +fi && + + +exit 0 diff --git a/cil/lib/Cilly.pm b/cil/lib/Cilly.pm new file mode 100644 index 0000000..fa7aa53 --- /dev/null +++ b/cil/lib/Cilly.pm @@ -0,0 +1,2137 @@ +# +# +# Copyright (c) 2001-2002, +# George C. Necula +# Scott McPeak +# Wes Weimer +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: +# +# 1. Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# +# 3. The names of the contributors may not be used to endorse or promote +# products derived from this software without specific prior written +# permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +# + + + +# This module implements a compiler stub that parses the command line +# arguments of gcc and Microsoft Visual C (along with some arguments for the +# script itself) and gives hooks into preprocessing, compilation and linking. + + +$::cilbin = 'bin'; + +package Cilly; +@ISA = (); + +use strict; +use File::Basename; +use File::Copy; +use File::Spec; +use Data::Dumper; +use Carp; +use Text::ParseWords; + +use KeptFile; +use OutputFile; +use TempFile; + +$Cilly::savedSourceExt = "_saved.c"; + +# Pass to new a list of command arguments +sub new { + my ($proto, @args) = @_; + + my $class = ref($proto) || $proto; + + my $ref = + { CFILES => [], # C input files + SFILES => [], # Assembly language files + OFILES => [], # Other input files + IFILES => [], # Already preprocessed files + EARLY_PPARGS => [], # Preprocessor args, first (pre-CIL) pass only + PPARGS => [], # Preprocessor args + CCARGS => [], # Compiler args + LINKARGS => [], # Linker args + NATIVECAML => 1, # this causes the native code boxer to be used + RELEASELIB => 0, # if true, use the release runtime library (if any) + # IDASHI => 1, # if true, pass "-I-" to gcc's preprocessor + IDASHDOT => 1, # if true, pass "-I." to gcc's preprocessor + VERBOSE => 0, # when true, print extra detail + TRACE_COMMANDS => 1, # when true, echo commands being run + SEPARATE => ! $::default_is_merge, + LIBDIR => [], + OPERATION => 'TOEXE', # This is the default for all compilers + }; + my $self = bless $ref, $class; + + if(! @args) { + print "No arguments passed\n"; + $self->printHelp(); + exit 0; + } + # Look for the --mode argument first. If not found it is GCC + my $mode = $::default_mode; + { + my @args1 = (); + foreach my $arg (@args) { + if($arg =~ m|--mode=(.+)$|) { + $mode = $1; + } else { + push @args1, $arg; + } + } + @args = @args1; # These are the argument after we extracted the --mode + + } + if(defined $self->{MODENAME} && $self->{MODENAME} ne $mode) { + die "Cannot re-specify the compiler"; + } + { + my $compiler; + if($mode eq "MSVC") { + unshift @Cilly::ISA, qw(MSVC); + $compiler = MSVC->new($self); + } elsif($mode eq "GNUCC") { + unshift @Cilly::ISA, qw(GNUCC); + $compiler = GNUCC->new($self); + } elsif($mode eq "MSLINK") { + unshift @Cilly::ISA, qw(MSLINK); + $compiler = MSLINK->new($self); + } elsif($mode eq "MSLIB") { + unshift @Cilly::ISA, qw(MSLIB); + $compiler = MSLIB->new($self); + } elsif($mode eq "AR") { + unshift @Cilly::ISA, qw(AR); + $compiler = AR->new($self); + } else { + die "Don't know about compiler $mode\n"; + } + # Now grab the fields from the compiler and put them inside self + my $key; + foreach $key (keys %{$compiler}) { + $self->{$key} = $compiler->{$key}; + } + + # For MSVC we have to use --save-temps because otherwise the + # temporary files get deleted somehow before CL gets at them ! + if($mode ne "GNUCC" && $mode ne "AR") { + $self->{SAVE_TEMPS} = '.'; + } + } + + # Scan and process the arguments + $self->setDefaultArguments; + collectArgumentList($self, @args); + + # sm: if an environment variable is set, then do not merge; this + # is intended for use in ./configure scripts, where merging delays + # the reporting of errors that the script is expecting + if (defined($ENV{"CILLY_NOMERGE"})) { + $self->{SEPARATE} = 1; + if($self->{VERBOSE}) { print STDERR "Merging disabled by CILLY_NOMERGE\n"; } + } + +# print Dumper($self); + + return $self; +} + +# Hook to let subclasses set/override default arguments +sub setDefaultArguments { +} + +# work through an array of arguments, processing each one +sub collectArgumentList { + my ($self, @args) = @_; + + # Scan and process the arguments + while($#args >= 0) { + my $arg = $self->fetchNextArg(\@args); + + if(! defined($arg)) { + last; + } + if($arg eq "") { next; } + + #print("arg: $arg\n"); +# +# my $arg = shift @args; # Grab the next one + if(! $self->collectOneArgument($arg, \@args)) { + print "Warning: Unknown argument $arg\n"; + push @{$self->{CCARGS}}, $arg; + } + } +} + +# Grab the next argument +sub fetchNextArg { + my ($self, $pargs) = @_; + return shift @{$pargs}; +} + +# Collecting arguments. Take a look at one argument. If we understand it then +# we return 1. Otherwise we return 0. Might pop some more arguments from pargs. +sub collectOneArgument { + my($self, $arg, $pargs) = @_; + my $res; + # Maybe it is a compiler option or a source file + if($self->compilerArgument($self->{OPTIONS}, $arg, $pargs)) { return 1; } + + if($arg eq "--help" || $arg eq "-help") { + $self->printVersion(); + $self->printHelp(); + exit 1; + } + if($arg eq "--version" || $arg eq "-version") { + $self->printVersion(); exit 0; + } + if($arg eq "--verbose") { + $self->{VERBOSE} = 1; return 1; + } + if($arg eq "--flatten_linker_scripts") { + $self->{FLATTEN_LINKER_SCRIPTS} = 1; return 1; + } + if($arg eq '--nomerge') { + $self->{SEPARATE} = 1; + return 1; + } + if($arg eq '--merge') { + $self->{SEPARATE} = 0; + return 1; + } + if($arg =~ "--ccargs=(.+)\$") { + push @{$self->{CCARGS}}, $1; + return 1; + } + if($arg eq '--trueobj') { + $self->{TRUEOBJ} = 1; + return 1; + } + # zf: force curing when linking to a lib + if ($arg eq '--truelib') { + $self->{TRUELIB} = 1; + return 1; + } + if($arg eq '--keepmerged') { + $self->{KEEPMERGED} = 1; + return 1; + } + if($arg eq '--stdoutpp') { + $self->{STDOUTPP} = 1; + return 1; + } + if($arg =~ m|--save-temps=(.+)$|) { + if(! -d $1) { + die "Cannot find directory $1"; + } + $self->{SAVE_TEMPS} = $1; + return 1; + } + if($arg eq '--save-temps') { + $self->{SAVE_TEMPS} = '.'; + return 1; + } + if($arg =~ m|--leavealone=(.+)$|) { + push @{$self->{LEAVEALONE}}, $1; + return 1; + } + if($arg =~ m|--includedir=(.+)$|) { + push @{$self->{INCLUDEDIR}}, $1; return 1; + } + if($arg =~ m|--stages|) { + $self->{SHOWSTAGES} = 1; + push @{$self->{CILARGS}}, $arg; + return 1; + } + if($arg eq "--bytecode") { + $self->{NATIVECAML} = 0; return 1; + } +# if($arg eq "--no-idashi") { +# $self->{IDASHI} = 0; return 1; +# } + if($arg eq "--no-idashdot") { + $self->{IDASHDOT} = 0; return 1; + } + + # sm: response file + if($arg =~ m|-@(.+)$| || + (($self->{MODENAME} eq "MSVC" || + $self->{MODENAME} eq "MSLINK" || + $self->{MODENAME} eq "MSLIB") && $arg =~ m|@(.+)$|)) { + my $fname = $1; # name of response file + &classifyArgDebug("processing response file: $fname\n"); + + # read the lines into an array + if (!open(RF, "<$fname")) { + die("cannot open response file $fname: $!\n"); + } + my @respArgs = (); + while() { + # Drop spaces and empty lines + my ($middle) = ($_ =~ m|\s*(\S.*\S)\s*|); + if($middle ne "") { + # Sometimes we have multiple arguments in one line :-() + if($middle =~ m|\s| && + $middle !~ m|[\"]|) { + # Contains spaces and no quotes + my @middles = split(/\s+/, $middle); + push @respArgs, @middles; + } else { + push @respArgs, $middle; + } +# print "Arg:$middle\n"; + } + } + close(RF) or die; + + + # Scan and process the arguments + collectArgumentList($self, @respArgs); + + #print("done with response file: $fname\n"); + return 1; # argument undestood + } + if($arg eq "-@" || ($self->{MODENAME} eq "MSVC" && $arg eq "@")) { + # sm: I didn't implement the case where it takes the next argument + # because I wasn't sure how to grab add'l args (none of the + # cases above do..) + die("For ccured/cilly, please don't separate the -@ from the\n", + "response file name. e.g., use -@", "respfile.\n"); + } + + # Intercept the --out argument + if($arg =~ m|^--out=(\S+)$|) { + $self->{CILLY_OUT} = $1; + push @{$self->{CILARGS}}, "--out", $1; + return 1; + } + # All other arguments starting with -- are passed to CIL + if($arg =~ m|^--|) { + # Split the == + if($arg =~ m|^(--\S+)=(.+)$|) { + push @{$self->{CILARGS}}, $1, $2; return 1; + } else { + push @{$self->{CILARGS}}, $arg; return 1; + } + } + return 0; +} + + +sub printVersion { + system ($CilCompiler::compiler, '--version'); +} + +sub printHelp { + my($self) = @_; + $self->usage(); + print <helpMessage(); +} + +# For printing the first line of the help message +sub usage { + my ($self) = @_; + print ""; +} + +# The rest of the help message +sub helpMessage { + my ($self) = @_; + print <{OUTLIB} . $dest); + # Pass the linkargs last because some libraries must be passed after + # the sources + my @cmd = (@{$self->{LDLIB}}, @dest, @{$ppargs}, @{$ccargs}, @sources, @{$ldargs}); + return $self->runShell(@cmd); +} + +# Customize the linking into libraries +sub linktolib { + my($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; + if($self->{VERBOSE}) { print STDERR "Linking into library $dest\n"; } + + # Now collect the files to be merged + my ($tomerge, $trueobjs, $ccargs) = + $self->separateTrueObjects($psrcs, $ccargs); + + if($self->{SEPARATE} || @{$tomerge} == 0) { + # Not merging. Regular linking. + + return $self->straight_linktolib($psrcs, $dest, + $ppargs, $ccargs, $ldargs); + } + # We are merging. Merge all the files into a single one + + if(@{$trueobjs} > 0) { + # We have some true objects. Save them into an additional file + my $trueobjs_file = "$dest" . "_trueobjs"; + if($self->{VERBOSE}) { + print STDERR + "Saving additional true object files in $trueobjs_file\n"; + } + open(TRUEOBJS, ">$trueobjs_file") || die "Cannot write $trueobjs_file"; + foreach my $true (@{$trueobjs}) { + my $abs = File::Spec->rel2abs($true); + print TRUEOBJS "$abs\n"; + } + close(TRUEOBJS); + } + if(@{$tomerge} == 1) { # Just copy the file over + (!system('cp', '-f', ${$tomerge}[0], $dest)) + || die "Cannot copy ${$tomerge}[0] to $dest\n"; + return ; + } + # + # We must do real merging + # + # Prepare the name of the CIL output file based on dest + my ($base, $dir, $ext) = fileparse($dest, "(\\.[^.]+)"); + + # Now prepare the command line for invoking cilly + my ($aftercil, @cmd) = $self->MergeCommand ($psrcs, $dir, $base); + die unless $cmd[0]; + + if($self->{MODENAME} eq "MSVC") { + push @cmd, "--MSVC"; + } + if($self->{VERBOSE}) { + push @cmd, "--verbose"; + } + if(defined $self->{CILARGS}) { + push @cmd, @{$self->{CILARGS}}; + } + # Eliminate duplicates + + # Add the arguments + if(@{$tomerge} > 20) { + my $extraFile = "___extra_files"; + open(TOMERGE, ">$extraFile") || die $!; + #FRANJO added the following on February 15th, 2005 + #REASON: extrafiles was TempFIle=HASH(0x12345678) + # instead of actual filename + my @normalized = @{$tomerge} ; + $_ = (ref $_ ? $_->filename : $_) foreach @normalized; + foreach my $fl (@normalized) { + print TOMERGE "$fl\n"; + } + close(TOMERGE); + push @cmd, '--extrafiles', $extraFile; + } else { + push @cmd, @{$tomerge}; + } + push @cmd, "--mergedout", $dest; + # Now run cilly + return $self->runShell(@cmd); +} + +############ +############ PREPROCESSING +############ +# +# All flavors of preprocessing return the destination file +# + +# THIS IS THE ENTRY POINT FOR COMPILING SOURCE FILES +sub preprocess_compile { + my ($self, $src, $dest, $early_ppargs, $ppargs, $ccargs) = @_; + &mydebug("preprocess_compile(src=$src, dest=$dest)\n"); + Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); + + my ($base, $dir, $ext) = fileparse($src, "\\.[^.]+"); + if($ext eq ".c" || $ext eq ".cpp" || $ext eq ".cc") { + if($self->leaveAlone($src)) { + print "Leaving alone $src\n"; + # We leave this alone. So just compile as usual + return $self->straight_compile($src, $dest, $early_ppargs, $ppargs, $ccargs); + } + my $out = $self->preprocessOutputFile($src); + $out = $self->preprocess($src, $out, + [@{$early_ppargs}, @{$ppargs}, + "$self->{DEFARG}CIL=1"]); + return $self->compile($out, $dest, $ppargs, $ccargs); + } + if($ext eq ".i") { + return $self->compile($src, $dest, $ppargs, $ccargs); + } + if($ext eq ".$::cilbin") { + return $self->compile($src, $dest, $ppargs, $ccargs); + } +} + +# THIS IS THE ENTRY POINT FOR JUST PREPROCESSING A FILE +sub preprocess { + my($self, $src, $dest, $ppargs) = @_; + Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); + return $self->preprocess_before_cil($src, $dest, $ppargs); +} + +# Find the name of the preprocessed file before CIL processing +sub preprocessOutputFile { + my($self, $src) = @_; + return $self->outputFile($src, 'i'); +} + +# Find the name of the preprocessed file after CIL processing +sub preprocessAfterOutputFile { + my($self, $src) = @_; + return $self->outputFile($src, 'cil.i'); +} + +# When we use CIL we have two separate preprocessing stages. First is the +# preprocessing before the CIL sees the code and the is the preprocessing +# after CIL sees the code + +sub preprocess_before_cil { + my ($self, $src, $dest, $ppargs) = @_; + Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); + my @args = @{$ppargs}; + + # See if we must force some includes + if(defined $self->{INCLUDEDIR} && !defined($ENV{"CILLY_NOCURE"})) { + # And force the other includes. Put them at the begining + if(($self->{MODENAME} eq 'GNUCC') && + # sm: m88k doesn't work if I pass -I. + $self->{IDASHDOT}) { + unshift @args, "-I."; + } + if(! defined($self->{VERSION})) { + $self->setVersion(); + } + unshift @args, + map { my $dir = $_; + $self->{INCARG} . $dir . "/" . $self->{VERSION} } + @{$self->{INCLUDEDIR}}; + #matth: include the main include dir as well as the compiler-specific directory + unshift @args, + map { my $dir = $_; + $self->{INCARG} . $dir } + @{$self->{INCLUDEDIR}}; + if($self->{MODENAME} eq 'GNUCC') { + # sm: this is incompatible with wu-ftpd, but is apparently needed + # for apache.. more investigation is needed + # update: now when I try it, apache works without -I- also.. but + # I'll make this into a switchable flag anyway + # matth: this breaks other tests. Let's try without. +# if ($self->{IDASHI}) { +# unshift @args, "-I-"; +# } + } + } + + return $self->straight_preprocess($src, $dest, \@args); +} + +# Preprocessing after CIL +sub preprocess_after_cil { + my ($self, $src, $dest, $ppargs) = @_; + Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); + return $self->straight_preprocess($src, $dest, $ppargs); +} + +# +# This is intended to be the true invocation of the underlying preprocessor +# You should not override this method +sub straight_preprocess { + my ($self, $src, $dest, $ppargs) = @_; + Carp::confess "bad dest: $dest" unless $dest->isa('OutputFile'); + if($self->{VERBOSE}) { + my $srcname = ref $src ? $src->filename : $src; + print STDERR "Preprocessing $srcname\n"; + } + if($self->{MODENAME} eq "MSVC" || + $self->{MODENAME} eq "MSLINK" || + $self->{MODENAME} eq "MSLIB") { + $self->MSVC::msvc_preprocess($src, $dest, $ppargs); + } else { +# print Dumper($self); + my @cmd = (@{$self->{CPP}}, @{$ppargs}, + $src, $self->makeOutArguments($self->{OUTCPP}, $dest)); + $self->runShell(@cmd); + + } + return $dest; +} + + +# +# +# +# COMPILATION +# +# + +sub compile { + my($self, $src, $dest, $ppargs, $ccargs) = @_; + &mydebug("Cilly.compile(src=$src, dest=$dest->{filename})\n"); + Carp::confess "bad dest: $dest->{filename}" + unless $dest->isa('OutputFile'); + + if($self->{SEPARATE}) { + # Now invoke CIL and compile afterwards + return $self->applyCilAndCompile([$src], $dest, $ppargs, $ccargs); + } + # We are merging + # If we are merging then we just save the preprocessed source + my ($mtime, $res, $outfile); + if(! $self->{TRUEOBJ}) { + $outfile = $dest->{filename}; $mtime = 0; $res = $dest; + } else { + # Do the real compilation + $res = $self->straight_compile($src, $dest, $ppargs, $ccargs); + # Now stat the result + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime_1,$ctime,$blksize,$blocks) = stat($dest->{filename}); + if(! defined($mtime_1)) { + die "Cannot stat the result of compilation $dest->{filename}"; + } + $mtime = $mtime_1; + $outfile = $dest->{filename} . $Cilly::savedSourceExt; + } + my $srcname = ref $src ? $src->filename : $src; + if($self->{VERBOSE}) { + print STDERR "Saving source $srcname into $outfile\n"; + } + open(OUT, ">$outfile") || die "Cannot create $outfile"; + my $toprintsrc = $srcname; + $toprintsrc =~ s|\\|/|g; + print OUT "#pragma merger($mtime,\"$toprintsrc\",\"" . + join(',', @{$ccargs}), "\")\n"; + open(IN, '<', $srcname) || die "Cannot read $srcname"; + while() { + print OUT $_; + } + close(OUT); + close(IN); + return $res; +} + +sub makeOutArguments { + my ($self, $which, $dest) = @_; + $dest = $dest->{filename} if ref $dest; + if($self->{MODENAME} eq "MSVC" || + $self->{MODENAME} eq "MSLINK" || + $self->{MODENAME} eq "MSLIB") { + # A single argument + return ("$which$dest"); + } else { + return ($which, $dest); + } +} +# This is the actual invocation of the underlying compiler. You should not +# override this +sub straight_compile { + my ($self, $src, $dest, $ppargs, $ccargs) = @_; + if($self->{VERBOSE}) { + print STDERR 'Compiling ', ref $src ? $src->filename : $src, ' into ', + $dest->filename, "\n"; + } + my @dest = + $dest eq "" ? () : $self->makeOutArguments($self->{OUTOBJ}, $dest); + my @forcec = @{$self->{FORCECSOURCE}}; + my @cmd = (@{$self->{CC}}, @{$ppargs}, @{$ccargs}, + @dest, @forcec, $src); + return $self->runShell(@cmd); +} + +# This is compilation after CIL +sub compile_cil { + my ($self, $src, $dest, $ppargs, $ccargs) = @_; + return $self->straight_compile($src, $dest, $ppargs, $ccargs); +} + + + +# THIS IS THE ENTRY POINT FOR JUST ASSEMBLING FILES +sub assemble { + my ($self, $src, $dest, $ppargs, $ccargs) = @_; + if($self->{VERBOSE}) { print STDERR "Assembling $src\n"; } + my @dest = + $dest eq "" ? () : $self->makeOutArguments($self->{OUTOBJ}, $dest); + my @cmd = (@{$self->{CC}}, @{$ppargs}, @{$ccargs}, + @dest, $src); + return $self->runShell(@cmd); +} + + + +# +# This is intended to be the true invocation of the underlying linker +# You should not override this method +sub straight_link { + my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; + my @sources = ref($psrcs) ? @{$psrcs} : ($psrcs); + my @dest = + $dest eq "" ? () : $self->makeOutArguments($self->{OUTEXE}, $dest); + # Pass the linkargs last because some libraries must be passed after + # the sources + my @cmd = (@{$self->{LD}}, @dest, + @{$ppargs}, @{$ccargs}, @sources, @{$ldargs}); + return $self->runShell(@cmd); +} + +# +# See if some libraries are actually lists of files +sub expandLibraries { + my ($self) = @_; + + my @tolink = @{$self->{OFILES}}; + + # Go through the sources and replace all libraries with the files that + # they contain + my @tolink1 = (); + while($#tolink >= 0) { + my $src = shift @tolink; +# print "Looking at $src\n"; + # See if the source is a library. Then maybe we should get instead the + # list of files + if($src =~ m|\.$self->{LIBEXT}$| && -f "$src.files") { + open(FILES, "<$src.files") || die "Cannot read $src.files"; + while() { + # Put them back in the "tolink" to process them recursively + while($_ =~ m|[\r\n]$|) { + chop; + } + unshift @tolink, $_; + } + close(FILES); + next; + } + # This is not for us + push @tolink1, $src; + next; + } + $self->{OFILES} = \@tolink1; +} + +# Go over a list of object files and separate them into those that are +# actually sources to be merged, and the true object files +# +sub separateTrueObjects { + my ($self, $psrcs, $ccargs) = @_; + + my @sources = @{$psrcs}; +# print "Sources are @sources\n"; + my @tomerge = (); + my @othersources = (); + + my @ccmerged = @{$ccargs}; + foreach my $src (@sources) { + my ($combsrc, $combsrcname, $mtime); + my $srcname = ref $src ? $src->filename : $src; + if(! $self->{TRUEOBJ}) { + # We are using the object file itself to save the sources + $combsrcname = $srcname; + $combsrc = $src; + $mtime = 0; + } else { + $combsrcname = $srcname . $Cilly::savedSourceExt; + $combsrc = $combsrcname; + if(-f $combsrcname) { + my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size, + $atime,$mtime_1,$ctime,$blksize,$blocks) = stat($srcname); + $mtime = $mtime_1; + } else { + $mtime = 0; + } + } + # Look inside and see if it is one of the files created by us + open(IN, "<$combsrcname") || die "Cannot read $combsrcname"; + my $fstline = ; + close(IN); + if($fstline =~ m|CIL|) { + goto ToMerge; + } + if($fstline =~ m|^\#pragma merger\((\d+),\".*\",\"(.*)\"\)$|) { + my $mymtime = $1; + # Get the CC flags + my @thisccargs = split(/,/, $2); + foreach my $arg (@thisccargs) { + # print "Looking at $arg\n ccmerged=@ccmerged\n"; + if(! grep(/$arg/, @ccmerged)) { + # print " adding it\n"; + push @ccmerged, $arg + } + } + ToMerge: + if($mymtime == $mtime) { # It is ours + # See if we have this already + if(! grep { $_ eq $srcname } @tomerge) { # It is ours + push @tomerge, $combsrc; + # See if there is a a trueobjs file also + my $trueobjs = $combsrcname . "_trueobjs"; + if(-f $trueobjs) { + open(TRUEOBJS, "<$trueobjs") + || die "Cannot read $trueobjs"; + while() { + chop; + push @othersources, $_; + } + close(TRUEOBJS); + } + } + next; + } + } + push @othersources, $combsrc; + } + # If we are merging, turn off "warnings are errors" flag + if(grep(/$self->{WARNISERROR}/, @ccmerged)) { + @ccmerged = grep(!/$self->{WARNISERROR}/, @ccmerged); + print STDERR "Turning off warn-is-error flag $self->{WARNISERROR}\n"; + } + + return (\@tomerge, \@othersources, \@ccmerged); +} + + +# Customize the linking +sub link { + my($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; + my $destname = ref $dest ? $dest->filename : $dest; + if($self->{SEPARATE}) { + if (!defined($ENV{CILLY_DONT_LINK_AFTER_MERGE})) { + if($self->{VERBOSE}) { print STDERR "Linking into $destname\n"; } + # Not merging. Regular linking. + return $self->link_after_cil($psrcs, $dest, + $ppargs, $ccargs, $ldargs); + } + else { + return 0; # sm: is this value used?? + } + } + my $mergedobj = new OutputFile($destname, + "${destname}_comb.$self->{OBJEXT}"); + + # We must merge + if($self->{VERBOSE}) { + print STDERR "Merging saved sources into $mergedobj->{filename} (in process of linking $destname)\n"; + } + + # Now collect the files to be merged + + my ($tomerge, $trueobjs, $ccargs) = + $self->separateTrueObjects($psrcs, $ccargs); + + if($self->{VERBOSE}) { + print STDERR "Will merge the following: ", + join(' ', @{$tomerge}), "\n"; + print STDERR "Will just link the genuine object files: ", + join(' ', @{$trueobjs}), "\n"; + print STDERR "After merge compile flags: @{$ccargs}\n"; + } + # Check the modification times and see if we can just use the combined + # file instead of merging all over again + if(@{$tomerge} > 1 && $self->{KEEPMERGED}) { + my $canReuse = 1; + my $combFile = new OutputFile($destname, + "${destname}_comb.c"); + my @tmp = stat($combFile); + my $combFileMtime = $tmp[9] || 0; + foreach my $mrg (@{$tomerge}) { + my @tmp = stat($mrg); my $mtime = $tmp[9]; + if($mtime >= $combFileMtime) { goto DoMerge; } + } + if($self->{VERBOSE}) { + print STDERR "Reusing merged file $combFile\n"; + } + $self->applyCilAndCompile([$combFile], $mergedobj, $ppargs, $ccargs); + } else { + DoMerge: + $self->applyCilAndCompile($tomerge, $mergedobj, $ppargs, $ccargs); + } + + # Put the merged OBJ at the beginning because maybe some of the trueobjs + # are libraries which like to be at the end + unshift @{$trueobjs}, $mergedobj; + + # And finally link + # zf: hack for linking linux stuff + if ($self->{TRUELIB}) { + my @cmd = (@{$self->{LDLIB}}, ($dest), + @{$ppargs}, @{$ccargs}, @{$trueobjs}, @{$ldargs}); + return $self->runShell(@cmd); + } + + # sm: hack: made this conditional for dsw + if (!defined($ENV{CILLY_DONT_LINK_AFTER_MERGE})) { + $self->link_after_cil($trueobjs, $dest, $ppargs, $ccargs, $ldargs); + } + +} + +sub applyCil { + my ($self, $ppsrc, $dest) = @_; + + # The input files + my @srcs = @{$ppsrc}; + + # Now prepare the command line for invoking cilly + my ($aftercil, @cmd) = $self->CillyCommand ($ppsrc, $dest); + Carp::confess "$self produced bad output file: $aftercil" + unless $aftercil->isa('OutputFile'); + + if($self->{MODENAME} eq "MSVC" || + $self->{MODENAME} eq "MSLINK" || + $self->{MODENAME} eq "MSLIB") { + push @cmd, '--MSVC'; + } + if($self->{VERBOSE}) { + push @cmd, '--verbose'; + } + if(defined $self->{CILARGS}) { + push @cmd, @{$self->{CILARGS}}; + } + + # Add the arguments + if(@srcs > 20) { + my $extraFile = "___extra_files"; + open(TOMERGE, ">$extraFile") || die $!; + foreach my $fl (@srcs) { + my $fname = ref $fl ? $fl->filename : $fl; + print TOMERGE "$fname\n"; + } + close(TOMERGE); + push @cmd, '--extrafiles', $extraFile; + } else { + push @cmd, @srcs; + } + if(@srcs > 1 && $self->{KEEPMERGED}) { + my ($base, $dir, undef) = fileparse($dest->filename, qr{\.[^.]+}); + push @cmd, '--mergedout', "$dir$base" . '.c'; + } + # Now run cilly + $self->runShell(@cmd); + + # Tell the caller where we put the output + return $aftercil; +} + + +sub applyCilAndCompile { + my ($self, $ppsrc, $dest, $ppargs, $ccargs) = @_; + Carp::confess "$self produced bad destination file: $dest" + unless $dest->isa('OutputFile'); + + # The input files + my @srcs = @{$ppsrc}; + &mydebug("Cilly.PM.applyCilAndCompile(srcs=[",join(',',@{$ppsrc}),"])\n"); + + # Now run cilly + my $aftercil = $self->applyCil($ppsrc, $dest); + Carp::confess "$self produced bad output file: $aftercil" + unless $aftercil->isa('OutputFile'); + + # Now preprocess + my $aftercilpp = $self->preprocessAfterOutputFile($aftercil); + $self->preprocess_after_cil($aftercil, $aftercilpp, $ppargs); + + if (!defined($ENV{CILLY_DONT_COMPILE_AFTER_MERGE})) { + # Now compile + return $self->compile_cil($aftercilpp, $dest, $ppargs, $ccargs); + } +} + +# Linking after CIL +sub link_after_cil { + my ($self, $psrcs, $dest, $ppargs, $ccargs, $ldargs) = @_; + if (!defined($ENV{CILLY_DONT_COMPILE_AFTER_MERGE})) { + return $self->straight_link($psrcs, $dest, $ppargs, $ccargs, $ldargs); + } +} + +# See if we must merge this one +sub leaveAlone { + my($self, $filename) = @_; + my ($base, $dir, $ext) = fileparse($filename, "(\\.[^.]+)"); + if(grep { $_ eq $base } @{$self->{LEAVEALONE}}) { + return 1; + } else { + return 0; + } +} + + +# DO EVERYTHING +sub doit { + my ($self) = @_; + my $file; + my $out; + +# print Dumper($self); + + # Maybe we must preprocess only + if($self->{OPERATION} eq "TOI" || $self->{OPERATION} eq 'SPECIAL') { + # Then we do not do anything + my @cmd = (@{$self->{CPP}}, + @{$self->{EARLY_PPARGS}}, + @{$self->{PPARGS}}, @{$self->{CCARGS}}, + @{$self->{CFILES}}, @{$self->{SFILES}}); + push @cmd, @{$self->{OUTARG}} if defined $self->{OUTARG}; + + return $self->runShell(@cmd); + } + # We expand some libraries names. Maybe they just contain some + # new object files + $self->expandLibraries(); + + # Try to guess whether to run in the separate mode. In that case + # we can go ahead with the compilation, without having to save + # files + if(! $self->{SEPARATE} && # Not already separate mode + $self->{OPERATION} eq "TOEXE" && # We are linking to an executable + @{$self->{CFILES}} + @{$self->{IFILES}} <= 1) { # At most one source + # If we have object files, we should keep merging if at least one + # object file is a disguised source + my $turnOffMerging = 0; + if(@{$self->{OFILES}}) { + my ($tomerge, $trueobjs, $mergedccargs) = + $self->separateTrueObjects($self->{OFILES}, $self->{CCARGS}); + $self->{CCARGS} = $mergedccargs; + $turnOffMerging = (@{$tomerge} == 0); + } else { + $turnOffMerging = 1; + } + if($turnOffMerging) { + if($self->{VERBOSE}) { + print STDERR + "Turn off merging because the program contains one file\n"; + } + $self->{SEPARATE} = 1; + } + } + + # Turn everything into OBJ files + my @tolink = (); + + foreach $file (@{$self->{IFILES}}, @{$self->{CFILES}}) { + $out = $self->compileOutputFile($file); + $self->preprocess_compile($file, $out, + $self->{EARLY_PPARGS}, + $self->{PPARGS}, $self->{CCARGS}); + push @tolink, $out; + } + # Now do the assembly language file + foreach $file (@{$self->{SFILES}}) { + $out = $self->assembleOutputFile($file); + $self->assemble($file, $out, $self->{PPARGS}, $self->{CCARGS}); + push @tolink, $out; + } + # Now add the original object files. Put them last because libraries like + # to be last. + push @tolink, @{$self->{OFILES}}; + + # See if we must stop after compilation + if($self->{OPERATION} eq "TOOBJ") { + return; + } + + # See if we must create a library only + if($self->{OPERATION} eq "TOLIB") { + if (!$self->{TRUELIB}) { + # zf: Creating a library containing merged source + $out = $self->linkOutputFile(@tolink); + $self->linktolib(\@tolink, $out, + $self->{PPARGS}, $self->{CCARGS}, + $self->{LINKARGS}); + return; + } else { + # zf: Linking to a true library. Do real curing. + # Only difference from TOEXE is that we use "partial linking" of the + # underlying linker + if ($self->{VERBOSE}) { + print STDERR "Linking to a true library!"; + } + push @{$self->{CCARGS}}, "-r"; + $out = $self->linkOutputFile(@tolink); + $self->link(\@tolink, $out, + $self->{PPARGS}, $self->{CCARGS}, $self->{LINKARGS}); + return; + } + + } + + # Now link all of the files into an executable + if($self->{OPERATION} eq "TOEXE") { + $out = $self->linkOutputFile(@tolink); + $self->link(\@tolink, $out, + $self->{PPARGS}, $self->{CCARGS}, $self->{LINKARGS}); + return; + } + + die "I don't understand OPERATION:$self->{OPERATION}\n"; +} + +sub classifyArgDebug { + if(0) { print @_; } +} + +sub mydebug { + if(0) { print @_; } +} + +sub compilerArgument { + my($self, $options, $arg, $pargs) = @_; + &classifyArgDebug("Classifying arg: $arg\n"); + my $idx = 0; + for($idx=0; $idx < $#$options; $idx += 2) { + my $key = ${$options}[$idx]; + my $action = ${$options}[$idx + 1]; + &classifyArgDebug("Try match with $key\n"); + if($arg =~ m|^$key|) { + &classifyArgDebug(" match with $key\n"); + my @fullarg = ($arg); + my $onemore; + if(defined $action->{'ONEMORE'}) { + &classifyArgDebug(" expecting one more\n"); + # Maybe the next arg is attached + my $realarg; + ($realarg, $onemore) = ($arg =~ m|^($key)(.+)$|); + if(! defined $onemore) { + # Grab the next argument + $onemore = $self->fetchNextArg($pargs); + $onemore = "eIfNecessary($onemore); + push @fullarg, $onemore; + } else { + $onemore = "eIfNecessary($onemore); + } + &classifyArgDebug(" onemore=$onemore\n"); + } + # Now see what action we must perform + my $argument_done = 1; + if(defined $action->{'RUN'}) { + &{$action->{'RUN'}}($self, @fullarg, $onemore, $pargs); + $argument_done = 1; + } + # Quote special SHELL caracters + @fullarg = map { $_ =~ s%([<>;&|])%'$1'%g; $_ } @fullarg; + # print "fullarg = ", @fullarg, "\n"; + if(defined $action->{'TYPE'}) { + &classifyArgDebug(" type=$action->{TYPE}\n"); + if($action->{TYPE} eq 'EARLY_PREPROC') { + push @{$self->{EARLY_PPARGS}}, @fullarg; return 1; + } + elsif($action->{TYPE} eq "PREPROC") { + push @{$self->{PPARGS}}, @fullarg; return 1; + } + elsif($action->{TYPE} eq 'SPECIAL') { + push @{$self->{PPARGS}}, @fullarg; + $self->{OPERATION} = 'SPECIAL'; + return 1; + } + elsif($action->{TYPE} eq "CC") { + push @{$self->{CCARGS}}, @fullarg; return 1; + } + elsif($action->{TYPE} eq "LINKCC") { + push @{$self->{CCARGS}}, @fullarg; + push @{$self->{LINKARGS}}, @fullarg; return 1; + } + elsif($action->{TYPE} eq "ALLARGS") { + push @{$self->{PPARGS}}, @fullarg; + push @{$self->{CCARGS}}, @fullarg; + push @{$self->{LINKARGS}}, @fullarg; return 1; + } + elsif($action->{TYPE} eq "LINK") { + push @{$self->{LINKARGS}}, @fullarg; return 1; + } + elsif($action->{TYPE} eq "CSOURCE") { + OutputFile->protect(@fullarg); + $fullarg[0] = &normalizeFileName($fullarg[0]); + push @{$self->{CFILES}}, @fullarg; return 1; + } + elsif($action->{TYPE} eq "ASMSOURCE") { + OutputFile->protect(@fullarg); + $fullarg[0] = &normalizeFileName($fullarg[0]); + push @{$self->{SFILES}}, @fullarg; return 1; + } + elsif($action->{TYPE} eq "OSOURCE") { + OutputFile->protect(@fullarg); + $fullarg[0] = &normalizeFileName($fullarg[0]); + push @{$self->{OFILES}}, @fullarg; return 1; + } + elsif($action->{TYPE} eq "ISOURCE") { + OutputFile->protect(@fullarg); + $fullarg[0] = &normalizeFileName($fullarg[0]); + push @{$self->{IFILES}}, @fullarg; return 1; + } + elsif($action->{TYPE} eq 'OUT') { + if(defined($self->{OUTARG})) { + print "Warning: output file is multiply defined: @{$self->{OUTARG}} and @fullarg\n"; + } + $fullarg[0] = &normalizeFileName($fullarg[0]); + $self->{OUTARG} = [@fullarg]; return 1; + } + print " Do not understand TYPE\n"; return 1; + } + if($argument_done) { return 1; } + print "Don't know what to do with option $arg\n"; + return 0; + } + } + return 0; +} + + +sub runShell { + my ($self, @cmd) = @_; + + my $msvcFriends = + ($self->{MODENAME} eq "MSVC" || + $self->{MODENAME} eq "MSLINK" || + $self->{MODENAME} eq "MSLIB"); + + foreach (@cmd) { + $_ = $_->filename if ref; + # If we are in MSVC mode then we might have to convert the files + # from cygwin names to the actual Windows names + if($msvcFriends && $^O eq "cygwin") { + my $arg = $_; + if ($arg =~ m|^/| && -f $arg) { + my $mname = `cygpath -m $arg`; + chop $mname; + if($mname ne "") { $_ = $mname; } + } + } + } + + # sm: I want this printed to stderr instead of stdout + # because the rest of 'make' output goes there and this + # way I can capture to a coherent file + # sm: removed conditional on verbose since there's already + # so much noise in the output, and this is the *one* piece + # of information I *always* end up digging around for.. + if($self->{TRACE_COMMANDS}) { print STDERR "@cmd\n"; } + + # weimer: let's have a sanity check + my $code = system { $cmd[0] } @cmd; + if ($code != 0) { + # sm: now that we always print, don't echo the command again, + # since that makes the output more confusing + #die "Possible error with @cmd!\n"; + $code >>= 8; # extract exit code portion + + exit $code; + } + return $code; +} + +sub quoteIfNecessary { + my($arg) = @_; + # If it contains spaces or "" then it must be quoted + if($arg =~ m|\s| || $arg =~ m|\"|) { + return "\'$arg\'"; + } else { + return $arg; + } +} + + +sub cilOutputFile { + Carp::croak 'bad argument count' unless @_ == 3; + my ($self, $basis, $suffix) = @_; + + if (defined $self->{SAVE_TEMPS}) { + return new KeptFile($basis, $suffix, $self->{SAVE_TEMPS}); + } else { + return $self->outputFile($basis, $suffix); + } +} + + +sub outputFile { + Carp::confess 'bad argument count' unless @_ == 3; + my ($self, $basis, $suffix) = @_; + + if (defined $self->{SAVE_TEMPS}) { + return new KeptFile($basis, $suffix, $self->{SAVE_TEMPS}); + } else { + return new TempFile($basis, $suffix); + } +} + + +########################################################################### +#### +#### MS CL specific code +#### +package MSVC; + +use strict; +use File::Basename; +use Data::Dumper; + +# For MSVC we remember which was the first source, because we use that to +# determine the name of the output file +sub setFirstSource { + my ($self, $src) = @_; + + if(! defined ($self->{FIRST_SOURCE})) { + $self->{FIRST_SOURCE} = $src; + } +} + +sub new { + my ($proto, $stub) = @_; + my $class = ref($proto) || $proto; + # Create $self + + my $self = + { NAME => 'Microsoft cl compiler', + MODENAME => 'MSVC', + CC => ['cl', '/nologo', '/D_MSVC', '/c'], + CPP => ['cl', '/nologo', '/D_MSVC', '/P'], + LD => ['cl', '/nologo', '/D_MSVC'], + DEFARG => "/D", + INCARG => "/I", + DEBUGARG => ['/Zi', '/MLd', '/DEBUG'], + OPTIMARG => ['/Ox', '/G6'], + OBJEXT => "obj", + LIBEXT => "lib", # Library extension (without the .) + EXEEXT => ".exe", # Executable extension (with the .) + OUTOBJ => "/Fo", + OUTEXE => "/Fe", + WARNISERROR => "/WX", + FORCECSOURCE => ['/Tc'], + LINEPATTERN => "^#line\\s+(\\d+)\\s+\"(.+)\"", + + OPTIONS => +# Describe the compiler options as a list of patterns and associated actions. +# The patterns are matched in order against the _begining_ of the argument. +# +# If the action contains ONEMORE => 1 then the argument is expected to be +# parameterized by a following word. The word can be attached immediately to +# the end of the argument or in a separate word. +# +# If the action contains TYPE => "..." then the argument is put into +# one of several lists, as follows: "PREPROC" in ppargs; "CC" in +# ccargs; "LINK" in linkargs; "LINKCC" both in ccargs and linkargs; +# "ALLARGS" in ppargs, ccargs, and linkargs; "CSOURCE" in cfiles; +# "ASMSOURCE" in sfiles; "OSOURCE" in ofiles; "ISOURCE" in ifiles; +# "OUT" in outarg. "SPECIAL" flags indicate that the compiler should +# be run directly so that it can perform some special action other +# than generating code (e.g. printing out version or configuration +# information). +# +# If the TYPE is not defined but the RUN => sub { ... } is defined then the +# given subroutine is invoked with the self, the argument and the (possibly +# empty) additional word and a pointer to the list of remaining arguments +# + ["^[^/\\-@].*\\.($::cilbin|c|cpp|cc)\$" => + { TYPE => 'CSOURCE', + RUN => sub { &MSVC::setFirstSource(@_); } }, + "[^/].*\\.(asm)\$" => { TYPE => 'ASMSOURCE' }, + "[^/].*\\.i\$" => { TYPE => 'ISOURCE' }, + "[^/\\-@]" => { TYPE => "OSOURCE" }, + "[/\\-]O" => { TYPE => "CC" }, + "[/\\-][DI]" => { TYPE => "PREPROC"}, + "[/\\-]EH" => { TYPE => "CC" }, + "[/\\-]G" => { TYPE => "CC" }, + "[/\\-]F[aA]" => { TYPE => 'CC' }, + "[/\\-]Fo" => { TYPE => 'OUT' }, + "/Fe" => { TYPE => 'OUT', + RUN => sub { $stub->{OPERATION} = "TOEXE" }}, + "[/\\-]F[dprR]" => { TYPE => "CC" }, + "[/\\-]FI" => { TYPE => "PREPROC" }, + "[/\\-][CXu]" => { TYPE => "PREPROC" }, + "[/\\-]U" => { ONEMORE => 1, TYPE => "PREPROC" }, + "[/\\-](E|EP|P)" => { RUN => sub { push @{$stub->{PPARGS}}, $_[1]; + $stub->{OPERATION} = "PREPROC"; }}, + "[/\\-]c" => { RUN => sub { $stub->{OPERATION} = "TOOBJ"; }}, + "[/\\-](Q|Z|J|nologo|w|W|Zm)" => { TYPE => "CC" }, + "[/\\-]Y(u|c|d|l|X)" => { TYPE => "CC" }, + "[/\\-]T(C|P)" => { TYPE => "PREPROC" }, + "[/\\-]Tc(.+)\$" => + { RUN => sub { + my $arg = $_[1]; + my ($fname) = ($arg =~ m|[/\\-]Tc(.+)$|); + $fname = &normalizeFileName($fname); + push @{$stub->{CFILES}}, $fname; + }}, + "[/\\-]v(d|m)" => { TYPE => "CC" }, + "[/\\-]F" => { TYPE => "CC" }, + "[/\\-]M" => { TYPE => 'LINKCC' }, + "/link" => { RUN => sub { push @{$stub->{LINKARGS}}, "/link", + @{$_[3]}; + @{$_[3]} = (); } }, + "-cbstring" => { TYPE => "CC" }, + "/" => { RUN => + sub { print "Unimplemented MSVC argument $_[1]\n";}}, + ], + }; + bless $self, $class; + return $self; +} + + +sub msvc_preprocess { + my($self, $src, $dest, $ppargs) = @_; + my $res; + my $srcname = ref $src ? $src->filename : $src; + my ($sbase, $sdir, $sext) = + fileparse($srcname, + "(\\.c)|(\\.cc)|(\\.cpp)|(\\.i)"); + # If this is a .cpp file we still hope it is C. Pass the /Tc argument to + # cl to force this file to be interpreted as a C one + my @cmd = @{$ppargs}; + + if($sext eq ".cpp") { + push @cmd, "/Tc"; + } + # MSVC cannot be told where to put the output. But we know that it + # puts it in the current directory + my $msvcout = "./$sbase.i"; + if($self->{STDOUTPP}) { + @cmd = ('cmd', '/c', 'cl', '/nologo', '/E', ">$msvcout", '/D_MSVC', + @cmd); + + } else { + @cmd = ('cl', '/nologo', '/P', '/D_MSVC', @cmd); + } + $res = $self->runShell(@cmd, $srcname); + # Check file equivalence by making sure that all elements of the stat + # structure are the same, except for the access time. + my @st1 = stat $msvcout; $st1[8] = 0; + my @st2 = stat $dest->{filename}; $st2[8] = 0; + # print Dumper(\@st1, \@st2); + if($msvcout ne $dest->{filename}) { + while($#st1 >= 0) { + if(shift @st1 != shift @st2) { +# print "$msvcout is NOT the same as $afterpp\n"; + if($self->{VERBOSE}) { + print STDERR "Copying $msvcout to $dest->{filename} (MSVC_preprocess)\n"; + } + unlink $dest; + File::Copy::copy($msvcout, $dest->filename); + unlink $msvcout; + return $res; + } + } + } + return $res; +} + +sub forceIncludeArg { + my($self, $what) = @_; + return "/FI$what"; +} + + + # MSVC does not understand the extension .i, so we tell it it is a C file +sub fixupCsources { + my (@csources) = @_; + my @mod_csources = (); + my $src; + foreach $src (@csources) { + my ($sbase, $sdir, $sext) = fileparse($src, + "\\.[^.]+"); + if($sext eq ".i") { + push @mod_csources, "/Tc"; + } + push @mod_csources, $src; + } + return @mod_csources; +} + + +# Emit a line # directive +sub lineDirective { + my ($self, $fileName, $lineno) = @_; + return "#line $lineno \"$fileName\"\n"; +} + +# The name of the output file +sub compileOutputFile { + my($self, $src) = @_; + + die "compileOutputFile: not a C source file: $src\n" + unless $src =~ /\.($::cilbin|c|cc|cpp|i|asm)$/; + + Carp::carp ("compileOutputFile: $self->{OPERATION}, $src", + Dumper($self->{OUTARG})) if 0; + if ($self->{OPERATION} eq 'TOOBJ') { + if(defined $self->{OUTARG} + && "@{$self->{OUTARG}}" =~ m|[/\\-]Fo(.+)|) { + my $dest = $1; + # Perhaps $dest is a directory + if(-d $dest) { + return new KeptFile($src, $self->{OBJEXT}, $dest); + } else { + return new OutputFile($src, $1); + } + } else { + return new KeptFile($src, $self->{OBJEXT}, '.'); + } + } else { +# die "compileOutputfile: operation is not TOOBJ"; + return $self->outputFile($src, $self->{OBJEXT}); + } +} + +sub assembleOutputFile { + my($self, $src) = @_; + return $self->compileOutputFile($src); +} + +sub linkOutputFile { + my($self, $src) = @_; + $src = $src->filename if ref $src; + if(defined $self->{OUTARG} && "@{$self->{OUTARG}}" =~ m|/Fe(.+)|) { + return $1; + } + # Use the name of the first source file, in the current directory + my ($base, $dir, $ext) = fileparse ($src, "\\.[^.]+"); + return "./$base.exe"; +} + +sub setVersion { + my($self) = @_; + my $cversion = ""; + open(VER, "cl 2>&1|") || die "Cannot start Microsoft CL\n"; + while() { + if($_ =~ m|Compiler Version (\S+) |) { + $cversion = "cl_$1"; + close(VER); + $self->{VERSION} = $cversion; + return; + } + } + die "Cannot find Microsoft CL version\n"; +} + +######################################################################## +## +## MS LINK specific code +## +### +package MSLINK; + +use strict; + +use File::Basename; +use Data::Dumper; + +sub new { + my ($proto, $stub) = @_; + my $class = ref($proto) || $proto; + + # Create a MSVC compiler object + my $msvc = MSVC->new($stub); + + # Create $self + + my $self = + { NAME => 'Microsoft linker', + MODENAME => 'MSLINK', + CC => $msvc->{CC}, + CPP => $msvc->{CPP}, + LD => ['link'], + DEFARG => $msvc->{DEFARG}, + INCARG => $msvc->{INCARG}, + DEBUGARG => ['/DEBUG'], + OPTIMARG => [], + LDLIB => ['lib'], + OBJEXT => "obj", + LIBEXT => "lib", # Library extension (without the .) + EXEEXT => ".exe", # Executable extension (with the .) + OUTOBJ => $msvc->{OUTOBJ}, + OUTEXE => "-out:", # Keep this form because build.exe looks for it + WARNISERROR => "/WX", + LINEPATTERN => "", + FORCECSOURCE => $msvc->{FORCECSOURCE}, + + MSVC => $msvc, + + OPTIONS => + ["[^/\\-@]" => { TYPE => 'OSOURCE' }, + "[/\\-](OUT|out):" => { TYPE => 'OUT' }, + "^((/)|(\\-[^\\-]))" => { TYPE => 'LINK' }, + ], + }; + bless $self, $class; + return $self; +} + + +sub forceIncludeArg { # Same as for CL + my($self, $what) = @_; + return "/FI$what"; +} + + + +sub linkOutputFile { + my($self, $src) = @_; +# print Dumper($self); + Carp::confess "Cannot compute the linker output file" + if ! defined $self->{OUTARG}; + + if("@{$self->{OUTARG}}" =~ m|.+:(.+)|) { + return $1; + } + die "I do not know what is the link output file\n"; +} + +sub setVersion { + my($self) = @_; + my $cversion = ""; + open(VER, "link 2>&1|") || die "Cannot start Microsoft LINK\n"; + while() { + if($_ =~ m|Linker Version (\S+)|) { + $cversion = "link_$1"; + close(VER); + $self->{VERSION} = $cversion; + return; + } + } + die "Cannot find Microsoft LINK version\n"; +} + +######################################################################## +## +## MS LIB specific code +## +### +package MSLIB; + +our @ISA = qw(MSLINK); + +use strict; + +use File::Basename; +use Data::Dumper; + +sub new { + my ($proto, $stub) = @_; + my $class = ref($proto) || $proto; + + # Create a MSVC linker object + my $self = MSLINK->new($stub); + + $self->{NAME} = 'Microsoft librarian'; + $self->{MODENAME} = 'MSLIB'; + $self->{OPERATION} = "TOLIB"; + $self->{LDLIB} = ['lib']; + bless $self, $class; + return $self; +} + +sub setVersion { + my($self) = @_; + my $cversion = ""; + open(VER, "lib 2>&1|") || die "Cannot start Microsoft LIB\n"; + while() { + if($_ =~ m|Library Manager Version (\S+)|) { + $cversion = "lib_$1"; + close(VER); + $self->{VERSION} = $cversion; + return; + } + } + die "Cannot find Microsoft LINK version\n"; +} + +######################################################################## +## +## GNU ar specific code +## +### +package AR; + +use strict; + +use File::Basename; +use Data::Dumper; + +sub new { + my ($proto, $stub) = @_; + my $class = ref($proto) || $proto; + # Create $self + + my $self = + { NAME => 'Archiver', + MODENAME => 'ar', + CC => ['no_compiler_in_ar_mode'], + CPP => ['no_compiler_in_ar_mode'], + LDLIB => ['ar', 'crv'], + DEFARG => "??DEFARG", + INCARG => '??INCARG', + DEBUGARG => ['??DEBUGARG'], + OPTIMARG => [], + OBJEXT => "o", + LIBEXT => "a", # Library extension (without the .) + EXEEXT => "", # Executable extension (with the .) + OUTOBJ => "??OUTOBJ", + OUTLIB => "", # But better be first + LINEPATTERN => "", + + OPTIONS => + ["^[^-]" => { RUN => \&arArguments } ] + + }; + bless $self, $class; + return $self; +} + +# We handle arguments in a special way for AR +sub arArguments { + my ($self, $arg, $onemore, $pargs) = @_; + # If the first argument starts with -- pass it on + if($arg =~ m|^--|) { + return 0; + } + # We got here for the first non -- argument. + # Will handle all arguments at once + if($self->{VERBOSE}) { + print "AR called with $arg @{$pargs}\n"; + } + + #The r flag is required: + if($arg !~ m|r| || $#{$pargs} < 0) { + die "Error: CCured's AR mode implements only the r and cr operations."; + } + if($arg =~ /[^crvus]/) { + die "Error: CCured's AR mode supports only the c, r, u, s, and v flags."; + } + if($arg =~ /v/) { + $self->{VERBOSE} = 1; + } + + if($arg =~ /c/) + { + # Command is "cr": + # Get the name of the library + my $out = shift @{$pargs}; + $self->{OUTARG} = [$out]; + unlink $out; + } + else + { + # if the command is "r" alone, we should add to the current library, + # not replace it, unless the library does not exist + + # Get the name of the library + my $out = shift @{$pargs}; + $self->{OUTARG} = [$out]; + + #The library is both an input and an output. + #To avoid problems with reading and writing the same file, move the + #current version of the library out of the way first. + if(-f $out) { + + my $temp_name = $out . "_old.a"; + if($self->{VERBOSE}) { + print "Copying $out to $temp_name so we can add " + . "to it.\n"; + } + if(-f $temp_name) { + unlink $temp_name; + } + rename $out, $temp_name; + + #now use $temp_name as the input. $self->{OUTARG} will, + # as usual, be the output. + push @{$self->{OFILES}}, $temp_name; + } else { + warn "Library $out not found; creating."; + } + + } + + # The rest of the arguments must be object files + push @{$self->{OFILES}}, @{$pargs}; + $self->{OPERATION} = 'TOLIB'; + @{$pargs} = (); +# print Dumper($self); + return 1; +} + +sub linkOutputFile { + my($self, $src) = @_; + if(defined $self->{OUTARG}) { + return "@{$self->{OUTARG}}"; + } + die "I do not know what is the link output file\n"; +} + +sub setVersion { + # sm: bin/cilly wants this for all "compilers" +} + + +######################################################################### +## +## GNUCC specific code +## +package GNUCC; + +use strict; + +use File::Basename; + +# The variable $::cc is inherited from the main script!! + +sub new { + my ($proto, $stub) = @_; + my $class = ref($proto) || $proto; + # Create $self + + my @native_cc = Text::ParseWords::shellwords($ENV{CILLY_NATIVE_CC} || $::cc); + + my $self = + { NAME => 'GNU CC', + MODENAME => 'GNUCC', # do not change this since it is used in code + # sm: added -O since it's needed for inlines to be merged instead of causing link errors + # sm: removed -O to ease debugging; will address "inline extern" elsewhere + CC => [@native_cc, '-D_GNUCC', '-c'], + LD => [@native_cc, '-D_GNUCC'], + LDLIB => ['ld', '-r', '-o'], + CPP => [@native_cc, '-D_GNUCC', '-E'], + DEFARG => "-D", + INCARG => "-I", + DEBUGARG => ['-g', '-ggdb'], + OPTIMARG => ['-O4'], + CPROFILEARG => '-pg', + LPROFILEARG => '-pg', + OBJEXT => "o", + LIBEXT => "a", + EXEEXT => "", + OUTOBJ => '-o', + OUTEXE => '-o', + OUTCPP => '-o', + WARNISERROR => "-Werror", + FORCECSOURCE => [], + LINEPATTERN => "^#\\s+(\\d+)\\s+\"(.+)\"", + + OPTIONS => + [ "[^-].*\\.($::cilbin|c|cpp|cc)\$" => { TYPE => 'CSOURCE' }, + "[^-].*\\.(s|S)\$" => { TYPE => 'ASMSOURCE' }, + "[^-].*\\.i\$" => { TYPE => 'ISOURCE' }, + # .o files can be linker scripts + "[^-]" => { RUN => sub { &GNUCC::parseLinkerScript(@_); }}, + "-E" => { RUN => sub { $stub->{OPERATION} = "TOI"; }}, + "-pipe\$" => { TYPE => 'ALLARGS' }, + "-[DIU]" => { ONEMORE => 1, TYPE => "PREPROC" }, + "-isystem" => { ONEMORE => 1, TYPE => "PREPROC" }, + '-undef$' => { TYPE => 'PREPROC' }, + '-w$' => { TYPE => 'PREPROC' }, + '-M$' => { TYPE => 'SPECIAL' }, + '-MM$' => { TYPE => 'SPECIAL' }, + '-MF$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 }, + '-C$' => { TYPE => 'EARLY_PREPROC'}, # zra + '-MG$' => { TYPE => 'EARLY_PREPROC' }, + '-MP$' => { TYPE => 'EARLY_PREPROC' }, + '-MT$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 }, + '-MQ$' => { TYPE => 'EARLY_PREPROC', ONEMORE => 1 }, + '-MD$' => { TYPE => 'EARLY_PREPROC' }, + '-MMD$' => { TYPE => 'EARLY_PREPROC' }, + "-include" => { ONEMORE => 1, TYPE => "PREPROC" }, # sm + "-iwithprefix" => { ONEMORE => 1, TYPE => "PREPROC" }, + '-Wp,' => { TYPE => 'PREPROC' }, + "-ansi" => { TYPE => 'ALLARGS' }, + "-c" => { RUN => sub { $stub->{OPERATION} = "TOOBJ"; }}, + "-x" => { ONEMORE => 1, TYPE => "CC" }, + "-v" => { TYPE => 'ALLARGS', + RUN => sub { $stub->{TRACE_COMMANDS} = 1; } }, + "^-e\$" => { ONEMORE => 1, TYPE => 'LINK' }, + "^-T\$" => { ONEMORE => 1, TYPE => 'LINK' }, + # GCC defines some more macros if the optimization is On so pass + # the -O to the preprocessor and the compiler + '-O' => { TYPE => 'ALLARGS' }, + "-S" => { RUN => sub { $stub->{OPERATION} = "TOOBJ"; + push @{$stub->{CCARGS}}, $_[1]; }}, + "-o" => { ONEMORE => 1, TYPE => 'OUT' }, + "-p\$" => { TYPE => 'LINKCC' }, + "-pg" => { TYPE => 'LINKCC' }, + "-a" => { TYPE => 'LINKCC' }, + "-pedantic\$" => { TYPE => 'ALLARGS' }, + "-Wall" => { TYPE => 'CC', + RUN => sub { push @{$stub->{CILARGS}},"--warnall";}}, + "-W[-a-z]*\$" => { TYPE => 'CC' }, + '-g' => { TYPE => 'ALLARGS' }, + "-save-temps" => { TYPE => 'ALLARGS', + RUN => sub { if(! defined $stub->{SAVE_TEMPS}) { + $stub->{SAVE_TEMPS} = '.'; } }}, + '--?print-' => { TYPE => 'SPECIAL' }, + '-dump' => { TYPE => 'SPECIAL' }, + "-l" => + { RUN => sub { + my ($libname) = ($_[1] =~ m|-l(.+)$|); + # See if we can find this library in the LIBDIR + my @libdirs = @{$stub->{LIBDIR}}; + if($#libdirs == -1) { + push @libdirs, '.'; + } + foreach my $d (@libdirs) { + if(-f "$d/lib$libname.a") { + # Pretend that we had a straight argument + push @{$stub->{OFILES}}, "$d/lib$libname.a"; + return; + } + } + # We get here when we cannot find the library in the LIBDIR + push @{$stub->{LINKARGS}}, $_[1]; + }}, + "-L" => + { RUN => sub { + # Remember these directories in LIBDIR + my ($dir) = ($_[1] =~ m|-L(.+)$|); + push @{$stub->{LIBDIR}}, $dir; + push @{$stub->{LINKARGS}}, $_[1]; + }}, + "-f" => { TYPE => 'LINKCC' }, + "-r\$" => { RUN => sub { $stub->{OPERATION} = "TOLIB"; }}, + "-i\$" => { RUN => sub { $stub->{OPERATION} = "TOLIB"; }}, + "-m" => { TYPE => 'LINKCC', ONEMORE => 1 }, + "-s\$" => { TYPE => 'LINKCC' }, + "-Xlinker" => { ONEMORE => 1, TYPE => 'LINK' }, + "-nostdlib" => { TYPE => 'LINK' }, + "-nostdinc" => { TYPE => 'PREPROC' }, + '-rdynamic$' => { TYPE => 'LINK' }, + "-static" => { TYPE => 'LINK' }, + "-shared" => { TYPE => 'LINK' }, + "-static-libgcc" => { TYPE => 'LINK' }, + "-shared-libgcc" => { TYPE => 'LINK' }, + '-Wl,--(no-)?whole-archive$' => { TYPE => 'OSOURCE' }, + '-Wl,' => { TYPE => 'LINK' }, + "-traditional" => { TYPE => 'PREPROC' }, + '-std=' => { TYPE => 'ALLARGS' }, + "--start-group" => { RUN => sub { } }, + "--end-group" => { RUN => sub { }}, + "-pthread\$" => { TYPE => 'ALLARGS' }, + ], + + }; + bless $self, $class; + return $self; +} +# ' + +my $linker_script_debug = 0; +sub parseLinkerScript { + my($self, $filename, $onemore, $pargs) = @_; + + if(! defined($self->{FLATTEN_LINKER_SCRIPTS}) || + $filename !~ /\.o$/) { + NotAScript: + warn "$filename is not a linker script\n" if $linker_script_debug; + push @{$self->{OFILES}}, $filename; + return 1; + } + warn "parsing OBJECT FILE:$filename ****************\n" if + $linker_script_debug; + open OBJFILE, $filename or die $!; + my $line = ; + if ($line !~ /^INPUT/) { + close OBJFILE or die $!; + goto NotAScript; + } + warn "\tYES an INPUT file.\n" if $linker_script_debug; + my @lines = ; # Read it all and close it + unshift @lines, $line; + close OBJFILE or die $!; + # Process recursively each line from the file + my @tokens = (); + my $incomment = 0; # Whether we are in a comment + foreach my $line (@lines) { + chomp $line; + if($incomment) { + # See where the comment ends + my $endcomment = index($line, "*/"); + if($endcomment < 0) { # No end on this line + next; # next line + } else { + $line = substr($line, $endcomment + 2); + $incomment = 0; + } + } + # Drop the comments that are on a single line + $line =~ s|/\*.*\*/| |g; + # Here if outside comment. See if a comment starts + my $startcomment = index($line, "/*"); + if($startcomment >= 0) { + $incomment = 1; + $line = substr($line, 0, $startcomment); + } + # Split the line into tokens. Sicne we use parentheses in the pattern + # the separators will be tokens as well + push @tokens, split(/([(),\s])/, $line); + } + print "Found tokens:", join(':', @tokens), "\n" + if $linker_script_debug; + # Now parse the file + my $state = 0; + foreach my $token (@tokens) { + if($token eq "" || $token =~ /\s+/) { next; } # Skip spaces + if($state == 0) { + if($token eq "INPUT") { $state = 1; next; } + else { die "Error in script: expecting INPUT"; } + } + if($state == 1) { + if($token eq "(") { $state = 2; next; } + else { die "Error in script: expecting ( after INPUT"; } + } + if($state == 2) { + if($token eq ")") { $state = 0; next; } + if($token eq ",") { next; } # Comma could be a separator + # Now we better see a filename + if(! -f $token) { + warn "Linker script mentions inexistent file:$token.Ignoring\n"; + next; + } + # Process it recursively because it could be a script itself + warn "LISTED FILE:$token.\n" if $linker_script_debug; + $self->parseLinkerScript($token, $onemore, $pargs); + next; + } + die "Invalid linker script parser state\n"; + + } +} + +sub forceIncludeArg { + my($self, $what) = @_; + return ('-include', $what); +} + + +# Emit a line # directive +sub lineDirective { + my ($self, $fileName, $lineno) = @_; + return "# $lineno \"$fileName\"\n"; +} + +# The name of the output file +sub compileOutputFile { + my($self, $src) = @_; + + die "objectOutputFile: not a C source file: $src\n" + unless $src =~ /\.($::cilbin|c|cc|cpp|i|s|S)$/; + + if ($self->{OPERATION} eq 'TOOBJ') { + if (defined $self->{OUTARG} + && "@{$self->{OUTARG}}" =~ m|^-o\s*(\S.+)$|) { + return new OutputFile($src, $1); + } else { + return new KeptFile($src, $self->{OBJEXT}, '.'); + } + } else { + return $self->outputFile($src, $self->{OBJEXT}); + } +} + +sub assembleOutputFile { + my($self, $src) = @_; + return $self->compileOutputFile($src); +} + +sub linkOutputFile { + my($self, $src) = @_; + if(defined $self->{OUTARG} && "@{$self->{OUTARG}}" =~ m|-o\s*(\S.+)|) { + return $1; + } + return "a.out"; +} + +sub setVersion { + my($self) = @_; + my $cversion = ""; + open(VER, "@{$self->{CC}} -dumpversion " + . join(' ', @{$self->{PPARGS}}) ." |") + || die "Cannot start GNUCC"; + while() { + if($_ =~ m|^(\d+\S+)| || $_ =~ m|^(egcs-\d+\S+)|) { + $cversion = "gcc_$1"; + close(VER) || die "Cannot start GNUCC\n"; + $self->{VERSION} = $cversion; + return; + } + } + die "Cannot find GNUCC version\n"; +} + +1; + + +__END__ + + + diff --git a/cil/lib/KeptFile.pm b/cil/lib/KeptFile.pm new file mode 100644 index 0000000..904b514 --- /dev/null +++ b/cil/lib/KeptFile.pm @@ -0,0 +1,88 @@ +package KeptFile; +use OutputFile; +@ISA = (OutputFile); + +use strict; +use Carp; +use File::Basename; +use File::Spec; + + +######################################################################## + + +sub new { + croak 'bad argument count' unless @_ == 4; + my ($proto, $basis, $suffix, $dir) = @_; + my $class = ref($proto) || $proto; + + $basis = $basis->basis if ref $basis; + my ($basename, undef, $basefix) = fileparse($basis, qr{\.[^.]+}); + my $filename = File::Spec->catfile($dir, "$basename.$suffix"); + + my $self = $class->SUPER::new($basis, $filename); + return $self; +} + + +######################################################################## + + +1; + +__END__ + + +=head1 Name + +KeptFile - persistent compiler output files + +=head1 Synopsis + + use KeptFile; + + my $cppOut = new KeptFile ('code.c', 'i', '/output/directory'); + system 'cpp', 'code.c', '-o', $cppOut->filename; + +=head2 Description + +C represents an intermediate output file generated by some +stage of a C-based compiler that should be retained after +compilation. It is a concrete subclass of L. +Use C when the user has asked for intermediate files to be +retained, such as via gcc's C<-save-temps> flag. + +=head2 Public Methods + +=over + +=item new + +C constructs a new C +instance. The new file name is constructed using the base file name +of C<$basis> with its suffix replaced by C<$suffix> and its path given +by C<$dir>. For example, + + new KeptFile ('/foo/code.c', 'i', '/bar') + +yields a C with file name F. + +C<$basis> may be either absolute or relative; only the trailing file +name is used. C<$basis> can also be an C instance, in +which case C<< $basis->basis >> is used as the actual basis. See +L for more information on basis flattening. + +C<$suffix> should not include a leading dot; this will be added +automatically. + +C<$dir> may be either absolute or relative. It is common to use F<.> +as the directory, which puts the C in the current working +directory. + +=back + +=head1 See Also + +L, L. + +=cut diff --git a/cil/lib/OutputFile.pm b/cil/lib/OutputFile.pm new file mode 100644 index 0000000..8f02ba2 --- /dev/null +++ b/cil/lib/OutputFile.pm @@ -0,0 +1,213 @@ +package OutputFile; +@ISA = (); + +use strict; +use Carp; +use File::Basename; +use File::Spec; + + +######################################################################## + + +my $debug = 0; + + +sub new { + croak 'bad argument count' unless @_ == 3; + my ($proto, $basis, $filename) = @_; + my $class = ref($proto) || $proto; + + $basis = $basis->basis if ref $basis; + my $ref = { filename => $filename, + basis => $basis }; + my $self = bless $ref, $class; + + $self->checkRef($filename); + $self->checkRef($basis); + $self->checkProtected(); + $self->checkTemporary(); + + Carp::cluck "OutputFile: filename == $filename, basis == $basis" if $debug; + return $self; +} + + +sub filename { + my ($self) = @_; + return $self->{filename}; +} + + +sub basis { + my ($self) = @_; + return $self->{basis}; +} + + +######################################################################## + + +sub checkRef { + my ($self, $filename) = @_; + confess "ref found where string expected: $filename" if ref $filename; + confess "stringified ref found where string expected: $filename" if $filename =~ /\w+=HASH\(0x[0-9a-f]+\)/; +} + + +sub checkTemporary { + my ($self) = @_; + my ($basename, $path) = fileparse $self->filename; + return if $path eq File::Spec->tmpdir . '/'; + confess "found temporary file in wrong directory: ", $self->filename + if $basename =~ /^cil-[a-zA-Z0-9]{8}\./; +} + + +######################################################################## + + +my @protected = (); + + +sub checkProtected { + my ($self) = @_; + my $abs = File::Spec->rel2abs($self->filename); + + foreach (@protected) { + confess "caught attempt to overwrite protected file: ", $self->filename + if $_ eq $abs; + } +} + + +sub protect { + my ($self, @precious) = @_; + push @protected, File::Spec->rel2abs($_) + foreach @precious; +} + + +######################################################################## + + +1; + +__END__ + + +=head1 Name + +OutputFile - base class for intermediate compiler output files + +=head1 Description + +C represents an intermediate output file generated by some +stage of a C-based compiler. This is an abstract base class +and should never be instantiated directly. It provides common +behaviors used by concrete subclasses L and +L. + +=head2 Public Methods + +=over + +=item filename + +An C instance is a smart wrapper around a file name. C<< +$out->filename >> returns the name of the file represented by +C instance C<$out>. When building a command line, this is +the string to use for the file. For example: + + my $out = ... ; # some OutputFile subclass + my @argv = ('gcc', '-E', '-o', $out->filename, 'input.c'); + system @argv; + +C often creates command vectors with a mix of strings and +C objects. This is fine, but before using a mixed vector +as a command line, you must replace all C objects with +their corresponding file names: + + my @mixed = (...); # mix of strings and objects + my @normalized = @mixed; + $_ = (ref $_ ? $_->filename : $_) foreach @normalized; + system @normalized; + +Common utility methods like C already do exactly this +normalization, but you may need to do it yourself if you are running +external commands on your own. + +=item protect + +C contains safety interlocks that help it avoid stomping +on user input files. C<< OutputFile->protect($precious) >> marks +C<$precious> as a protected input file which should not be +overwritten. If any C tries to claim this same file name, +an error will be raised. In theory, this never happens. In practice, +scripts can have bugs, and it's better to be safe than sorry. + +C uses this method to register input files that it discovers +during command line processing. If you add special command line +processing of your own, or if you identify input files through other +means, we highly recommend using this method as well. Otherwise, +there is some risk that a buggy client script could mistakenly create +an output file that destroys the user's source code. + +Note that C is a class method: call it on the C +module, rather than on a specific instance. + +=back + +=head2 Internal Methods + +The following methods are used within C or by +C subclasses. They are not intended for use by outside +scripts. + +=over + +=item basis + +In addition to L, each C +instance records a second file name: its I. The basis file +name is initialized and used differently by different subclasses, but +typically represents the input file from which this output file is +derived. C<< $out->basis >> returns the basis file name for instance +C<$out>. + +When instantiating an C, the caller can provide either a +file name string as the basis or another C instance. +However, basis file names are not chained: if C<< $a->basis >> is +F, and C<$b> is constructed with C<$a> as its basis, C<< +$b->basis >> will return F, not C<$a> or C<< $a->filename >>. +This flattening is done at construction time. + +See L and L for more details on how +basis file names are used. + +=item checkRef + +C<< OutputFile->checkRef($filename) >> raises an error if C<$filename> +is an object reference, or looks like the string representation of an +object reference. Used to sanity check arguments to various methods. + +=item checkTemporary + +C<< $out->checkTemporary >> raises an error if C<< $out->filename >> +looks like a temporary file name but is not in the system temporary +directory. Used to sanity check arguments in various methods. + +=item checkProtected + +C<< $out->checkProtected >> raises an error if C<< $out->filename >> +is listed as a protected file. This check, performed at construction +time, implements a safety interlock to prevent overwriting of user +input files. Protected files are registered using L<"protect">. + +=back + +=head1 See Also + +L, L. + +=cut diff --git a/cil/lib/TempFile.pm b/cil/lib/TempFile.pm new file mode 100644 index 0000000..608713c --- /dev/null +++ b/cil/lib/TempFile.pm @@ -0,0 +1,90 @@ +package TempFile; +use OutputFile; +@ISA = (OutputFile); + +use strict; +use Carp; +use File::Temp qw(tempfile); + + +######################################################################## + + +sub new { + croak 'bad argument count' unless @_ == 3; + my ($proto, $basis, $suffix) = @_; + my $class = ref($proto) || $proto; + + my (undef, $filename) = tempfile('cil-XXXXXXXX', + DIR => File::Spec->tmpdir, + SUFFIX => ".$suffix", + UNLINK => 1); + + my $self = $class->SUPER::new($basis, $filename); + return $self; +} + + +######################################################################## + + +1; + +__END__ + + +=head1 Name + +TempFile - transitory compiler output files + +=head1 Synopsis + + use TempFile; + + my $cppOut = new TempFile ('code.c', 'i'); + system 'cpp', 'code.c', '-o', $cppOut->filename; + +=head2 Description + +C represents an intermediate output file generated by some +stage of a C-based compiler that should be removed after +compilation. It is a concrete subclass of L. +Use C when the user has asked not for intermediate files to +be retained. + +All C files are removed when the script terminates. This +cleanup happens for both normal exits as well as fatal errors. +However, the standard L does not +perform cleanups, and therefore should be avoided in scripts that use +C. + +=head2 Public Methods + +=over + +=item new + +C constructs a new C +instance. The new file name is constructed in some system-specific +temporary directory with a randomly generated file name that ends with +C<$suffix>. For example, + + new TempFile ('/foo/code.c', 'i') + +might yield a C with file name F. + +C<$basis> gives the basis file name for this instance. The file name +is not used directly, but is retained in case this instance is later +passed as the basis for some other C. See +L for more information on basis flattening. + +C<$suffix> should not include a leading dot; this will be added +automatically. + +=back + +=head1 See Also + +L, L. + +=cut diff --git a/cil/ocamlutil/Makefile.ocaml b/cil/ocamlutil/Makefile.ocaml new file mode 100644 index 0000000..1d0673f --- /dev/null +++ b/cil/ocamlutil/Makefile.ocaml @@ -0,0 +1,395 @@ +# -*- Mode: makefile -*- +# Copyright (c) 2001-2002, +# George C. Necula +# Scott McPeak +# Wes Weimer +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: +# +# 1. Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# +# 3. The names of the contributors may not be used to endorse or promote +# products derived from this software without specific prior written +# permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + # Generic Makefile for Ocaml projects + # Written by necula@cs.berkeley.edu + # + # Features: + # - keeps byproducts of building in a separate directory + # - handles dependencies automatically + # - user specifies just what modules go into a project and + # everything else is done automatically + # - you can use one Makefile for several Ocaml projects + # + # You must include this file in your Makefile. Before the include point + # you must defined the following variables (which are glob al for all Ocaml + # projects specified in one Makefile): + # + # CAMLDIR - the directory where to get the ocaml executables from. + # Must be empty (defaul) or end with a / + # OBJDIR - the directory where to put all object files. This directory + # must exist (default obj) + # DEPENDDIR - the directory where to put dependency files. This directory + # must exist. (default obj/.depend) + # NATIVECAML - if set then will use the native compiler + # UNSAFE - if set then will turn off safety checks (only with NATIVECAML) + # PROFILE - if set then it will compile and link with "gprof" profiling + # support (NATIVECAML mode only) + # ASSEMBLY - if set then it will keep assembly files + # STATIC - if set then it will compile and link statically + # (NATIVECAML mode only) + # PREPROC - the preprocessor command + + # MODULES - a list of all modules for all projects defined in the + # Makefile. Give only the basenames (no directory, + # no extension). This is used to create the dependencies. + # SOURCEDIRS - a list of all directories containing sources for all + # projects defined in a Makefile. This is used to set vpath. + # MLLS - a list of all .mll (ocamllex input) files for all + # projects defined in the Makefile. + # MLYS - a list of all .mly (ocamlyacc input) files for all + # projects defined in the Makefile. + # ECHO - if specifically set to nothing then it will print + # all of the commands issued. Set this in the command line + # if you want to see what is going on. + # + # COMPILEFLAGS - if defined, then it is passed as argument to ocamlc + # and ocamlopt + # LINKFLAGS - if defined, then it is passed as argument to + # ocamlc and ocamlopt, when linking (at start of + # command line) + # + # CAML_CFLAGS - flags used only for the compilation of C files. + # e.g. '-ccopt ' + # + # + # After you set all of the above you must do the following for EACH separate + # executable that you want to build. + # + # Define the following: + # PROJECT_EXECUTABLE - the name of the executable you want to build. To take + # advantage of the naming scheme that separates the + # bytecode version and the native version, use the + # $(EXE) variable which is defined to either .byte.exe + # or .asm.exe. I typically put the executable in + # $(OBJDIR) as well. + # PROJECT_MODULES - the base names of the modules that make this + # executable in the order in which they must be + # passed to the linker. Make sure that all of + # the names mentioned here are also mentioned in + # MODULES. + # PROJECT_CMODULES - same as modules but for the C modules. These + # do not need to be mentioned in MODULES. There must be + # no name clashes with MODULES + # PROJECT_LIBS - the base names of the libraries that you + # want to link in the executable. + # + # + # Then include Makefile.ocaml.build to generate a customized + # rule for making your executable. + # + # Example: + # + # OBJDIR = obj + # DEPENDDIR = obj/.depend + # SOURCEDIRS = src src/special + # MLLS = mylex + # MLYS = myparse + # + # MODULES = mod11 mod12 mod21 modcommon + # + # # Rules for project 1 + # PROJECT_EXECUTABLE = $(OBJDIR)/proj1$(EXE) + # PROJECT_MODULES = mod11 mod12 modcommon + # PROJECT_CMODULES = + # PROJEC_LIBS = unix + # include Makefile.ocaml.build + # + # + # # Rules for project 2 + # PROJECT_EXECUTABLE = $(OBJDIR)/proj2$(EXE) + # PROJECT_MODULES = mod21 modcommon + # PROJECT_CMODULES = + # PROJEC_LIBS = unix str + # include Makefile.ocaml.build + + +CAMLLEX = ocamllex +CAMLYACC= ocamlyacc -v +CAMLDEP = ocamldep + +COMPILEFLAGS += -I $(OBJDIR) + +# sm: two styles for echoing compilation progress: +# style 1, by George: +# - print English descriptions of what's happening +# - set ECHO to "" to see *everything* +# style 2, by Scott: +# - do not print English descriptions +# - print every shell command that is executed which has a side effect, +# so that they could be pasted into a shell to reproduce manually +# - omit some of the details of dependency generation +# +# to be able to choose which style, several variables are used: +# @$(NARRATIVE) - put this before English descriptions for style 1 +# @$(COMMAND) - put this before shell commands which are to be +# printed for style 2; the command is *not* executed +# $(AT) - put this before shell commands which are to be executed, +# and also printed in style 2 +# $(ECHO) - use in place of '@' for things not printed in either style +ifdef ECHOSTYLE_SCOTT + # 'true' silently consumes its arguments, whereas 'echo' prints them + NARRATIVE := true + COMMAND := echo + AT := + ECHO := @ +else + NARRATIVE := echo + COMMAND := true + # change these next two definitions to to echo everything, + # or leave as @ to suppress echoing + AT := @ + ECHO := @ +endif + +ifdef PREPROC + COMPILEFLAGS += -pp "$(PREPROC)$" + DEPFLAGS += -pp "$(PREPROC)" +endif + +COMPILEMSG= +LINKMSG= + +ifdef WIN32 +OBJ = obj +else +OBJ = o +endif +EXE = $(EXEEXT).exe + + +export EXE + +ifdef NATIVECAML + ifdef PROFILE + COMPILEFLAGS += -p + LINKFLAGS += -p + COMPILEMSG += (profile) + LINKMSG += (profile) + endif + ifdef ASSEMBLY + COMPILEFLAGS += -S + endif + ifdef STATIC + COMPILEFLAGS += -ccopt -static + LINKFLAGS += -ccopt -static + endif + #foo := $(shell echo "I am in NATIVECAML mode" >&2; echo whatever) + ifdef WIN32 + COMPILEFLAGS += -ccopt /Ox + else + COMPILEFLAGS += -ccopt -O3 + endif + CAMLC = $(CAMLDIR)ocamlopt $(COMPILEFLAGS) + CAMLLINK = $(CAMLDIR)ocamlopt $(LINKFLAGS) + CMO = cmx + CMC = opt.$(OBJ) # compiled (and optimized) C + CMXA = cmxa + EXEEXT = .asm + MOVEAFTERCAMLC = cmi cmx $(OBJ) + COMPILETOWHAT = native code + # sm: by adding -native in native mode, we prevent spurious + # dependencies on .cmo files which were causing lots of + # extra recompilation + CAMLDEP = $(CAMLDIR)ocamldep -native +else + CMO = cmo + CMXA = cma + CMC = $(OBJ) + EXEEXT = .byte + MOVEAFTERCAMLC = cmi cmo + COMPILETOWHAT = bytecode + ifdef WIN32 + COMPILEFLAGS += -ccopt /Zi -ccopt /Od + LINKFLAGS += -ccopt /Zi -ccopt /Od + else + COMPILEFLAGS += -g -ccopt -g + LINKFLAGS += -g -ccopt -g + endif + CAMLC = $(CAMLDIR)ocamlc -g $(COMPILEFLAGS) + CAMLLINK = $(CAMLDIR)ocamlc -custom $(LINKFLAGS) +endif + + +ifdef UNSAFE + CAMLC := $(CAMLC) -unsafe -noassert +endif + + + + + # Allow searching for .ml and .mli +vpath %.mll $(SOURCEDIRS) +vpath %.mly $(SOURCEDIRS) +vpath %.ml $(SOURCEDIRS) $(OBJDIR) +vpath %.mli $(SOURCEDIRS) $(OBJDIR) +vpath %.c $(SOURCEDIRS) + + +# Secondaries are intermediates that we don't want make to delete +# By giving the right names to secondary files we tell make where to make +# them if they are not already made. VERY USEFUL!! +.SECONDARY : $(MLLS:%.mll=$(OBJDIR)/%.ml) $(MLYS:%.mly=$(OBJDIR)/%.ml) \ + $(MLYS:%.mly=$(OBJDIR)/%.mli) + + # Run the lexer generator + # Move the result to the OBJDIR directory + # If there is a .mli file in the same directory with .mll then + # copy it to OBJDIR (where the .ml) file will live. +$(OBJDIR)/%.ml: %.mll + $(CAMLLEX) $< + $(AT)mv -f $(basename $<).ml $(OBJDIR)/ + $(ECHO)if test -f $(basename $<).mli ;then \ + $(COMMAND) cp -f $(basename $<).mli $(OBJDIR)/; \ + cp -f $(basename $<).mli $(OBJDIR)/ \ + ;fi + + # Run the parser generator + # Move the result to the $(OBJDIR) directory. +$(OBJDIR)/%.ml $(OBJDIR)/%.mli: %.mly + $(CAMLYACC) $(CAMLYACCFLAGS) $< + $(AT)mv -f $(basename $<).ml $(basename $<).mli $(OBJDIR)/ + + # Compile an MLI file. After compilation move the result to OBJDIR +$(OBJDIR)/%.cmi: %.mli + @$(NARRATIVE) Compiling interface $< + $(AT)$(CAMLC) $(COMPILEFLAGS) -c $< + $(ECHO)if test $(OBJDIR) != $() { s%[^/\\ :]*/% %g; s%[^/\\ :]+\\% %g; s%([-a-zA-Z0-9+-.:/\/_]+)%\$$(OBJDIR)/$$1%g; print $$_;}' +# FIXDEPEND:=cat + +DEPINCLUDES= -I $(OBJDIR) $(SOURCEDIRS:%=-I %) +$(DEPENDDIR)/%.d: %.ml + @$(NARRATIVE) Generating dependency information for $< + @$(COMMAND) $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $< + $(ECHO)$(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $< | $(FIXDEPEND) > $@ + +$(DEPENDDIR)/%.di: %.mli + @$(NARRATIVE) Generating dependency information for $< + @$(COMMAND) $(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $< + $(ECHO)$(CAMLDEP) $(DEPFLAGS) $(DEPINCLUDES) $< | $(FIXDEPEND) > $@ + +# sm: it turns out there's a variable which lists all the goals +# specified on the command line; I'll use this to set CLEANING +# (which is not set anywhere else, currently) +ifeq ($(MAKECMDGOALS),clean) + #$(warning "Skipping dependency rules because we're cleaning") + CLEANING := 1 +endif + +ifndef CLEANING +-include $(MODULES:%=$(DEPENDDIR)/%.d) +-include $(MODULES:%=$(DEPENDDIR)/%.di) +endif + +listmodules: + @echo $(MODULES) diff --git a/cil/ocamlutil/Makefile.ocaml.build b/cil/ocamlutil/Makefile.ocaml.build new file mode 100644 index 0000000..5271e46 --- /dev/null +++ b/cil/ocamlutil/Makefile.ocaml.build @@ -0,0 +1,50 @@ +# -*- Mode: makefile -*- +# Copyright (c) 2001-2002, +# George C. Necula +# Scott McPeak +# Wes Weimer +# All rights reserved. +# +# Redistribution and use in source and binary forms, with or without +# modification, are permitted provided that the following conditions are +# met: +# +# 1. Redistributions of source code must retain the above copyright +# notice, this list of conditions and the following disclaimer. +# +# 2. Redistributions in binary form must reproduce the above copyright +# notice, this list of conditions and the following disclaimer in the +# documentation and/or other materials provided with the distribution. +# +# 3. The names of the contributors may not be used to endorse or promote +# products derived from this software without specific prior written +# permission. +# +# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS +# IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED +# TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A +# PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +# OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, +# EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +# PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +# PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +# LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +# NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +# SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + # Auxiliary Makefile for building Ocaml project. See the documentation in + # the associated Makefile.ocaml for how to use this file. + # Written by necula@cs.berkeley.edu + # +$(PROJECT_EXECUTABLE) : $(PROJECT_MODULES:%=$(OBJDIR)/%.$(CMO)) \ + $(PROJECT_CMODULES:%=$(OBJDIR)/%.$(CMC)) + @$(NARRATIVE) "Linking $(COMPILETOWHAT) $@ $(LINKMSG)" + $(AT)$(CAMLLINK) -verbose -o $@ \ + $(PROJECT_LIBS:%=%.$(CMXA)) \ + $(PROJECT_LIBS:%=-cclib -l%) \ + $^ + + + + + diff --git a/cil/ocamlutil/alpha.ml b/cil/ocamlutil/alpha.ml new file mode 100755 index 0000000..6a1ea01 --- /dev/null +++ b/cil/ocamlutil/alpha.ml @@ -0,0 +1,156 @@ +module H = Hashtbl +module E = Errormsg +open Pretty + +let debugAlpha (prefix: string) = false +(*** Alpha conversion ***) +let alphaSeparator = "___" +let alphaSeparatorLen = String.length alphaSeparator + +(** For each prefix we remember the next integer suffix to use and the list + * of suffixes, each with some data assciated with the newAlphaName that + * created the suffix. *) +type 'a alphaTableData = int * (string * 'a) list + +type 'a undoAlphaElement = + AlphaChangedSuffix of 'a alphaTableData ref * 'a alphaTableData (* The + * reference that was changed and + * the old suffix *) + | AlphaAddedSuffix of string (* We added this new entry to the + * table *) + +(* Create a new name based on a given name. The new name is formed from a + * prefix (obtained from the given name by stripping a suffix consisting of + * the alphaSeparator followed by only digits), followed by alphaSeparator + * and then by a positive integer suffix. The first argument is a table + * mapping name prefixes to the largest suffix used so far for that + * prefix. The largest suffix is one when only the version without suffix has + * been used. *) +let rec newAlphaName ~(alphaTable: (string, 'a alphaTableData ref) H.t) + ~(undolist: 'a undoAlphaElement list ref option) + ~(lookupname: string) + ~(data: 'a) : string * 'a = + alphaWorker ~alphaTable:alphaTable ~undolist:undolist + ~lookupname:lookupname ~data:data true + + +(** Just register the name so that we will not use in the future *) +and registerAlphaName ~(alphaTable: (string, 'a alphaTableData ref) H.t) + ~(undolist: 'a undoAlphaElement list ref option) + ~(lookupname: string) + ~(data: 'a) : unit = + ignore (alphaWorker ~alphaTable:alphaTable ~undolist:undolist + ~lookupname:lookupname ~data:data false) + + +and alphaWorker ~(alphaTable: (string, 'a alphaTableData ref) H.t) + ~(undolist: 'a undoAlphaElement list ref option) + ~(lookupname: string) ~(data:'a) + (make_new: bool) : string * 'a = + let prefix, suffix, (numsuffix: int) = splitNameForAlpha ~lookupname in + if debugAlpha prefix then + ignore (E.log "Alpha worker: prefix=%s suffix=%s (%d) create=%b. " + prefix suffix numsuffix make_new); + let newname, (olddata: 'a) = + try + let rc = H.find alphaTable prefix in + let max, suffixes = !rc in + (* We have seen this prefix *) + if debugAlpha prefix then + ignore (E.log " Old max %d. Old suffixes: @[%a@]" max + (docList + (fun (s, l) -> dprintf "%s" (* d_loc l *) s)) suffixes); + (* Save the undo info *) + (match undolist with + Some l -> l := AlphaChangedSuffix (rc, !rc) :: !l + | _ -> ()); + + let newmax, newsuffix, (olddata: 'a), newsuffixes = + if numsuffix > max then begin + (* Clearly we have not seen it *) + numsuffix, suffix, data, + (suffix, data) :: suffixes + end else begin + match List.filter (fun (n, _) -> n = suffix) suffixes with + [] -> (* Not found *) + max, suffix, data, (suffix, data) :: suffixes + | [(_, l) ] -> + (* We have seen this exact suffix before *) + if make_new then + let newsuffix = alphaSeparator ^ (string_of_int (max + 1)) in + max + 1, newsuffix, l, (newsuffix, data) :: suffixes + else + max, suffix, data, suffixes + | _ -> E.s (E.bug "Cil.alphaWorker") + end + in + rc := (newmax, newsuffixes); + prefix ^ newsuffix, olddata + with Not_found -> begin (* First variable with this prefix *) + (match undolist with + Some l -> l := AlphaAddedSuffix prefix :: !l + | _ -> ()); + H.add alphaTable prefix (ref (numsuffix, [ (suffix, data) ])); + if debugAlpha prefix then ignore (E.log " First seen. "); + lookupname, data (* Return the original name *) + end + in + if debugAlpha prefix then + ignore (E.log " Res=: %s \n" newname (* d_loc oldloc *)); + newname, olddata + +(* Strip the suffix. Return the prefix, the suffix (including the separator + * and the numeric value, possibly empty), and the + * numeric value of the suffix (possibly -1 if missing) *) +and splitNameForAlpha ~(lookupname: string) : (string * string * int) = + let len = String.length lookupname in + (* Search backward for the numeric suffix. Return the first digit of the + * suffix. Returns len if no numeric suffix *) + let rec skipSuffix (i: int) = + if i = -1 then -1 else + let c = Char.code (String.get lookupname i) - Char.code '0' in + if c >= 0 && c <= 9 then + skipSuffix (i - 1) + else (i + 1) + in + let startSuffix = skipSuffix (len - 1) in + + if startSuffix >= len (* No digits at all at the end *) || + startSuffix <= alphaSeparatorLen (* Not enough room for a prefix and + * the separator before suffix *) || + (* Suffix starts with a 0 and has more characters after that *) + (startSuffix < len - 1 && String.get lookupname startSuffix = '0') || + alphaSeparator <> String.sub lookupname + (startSuffix - alphaSeparatorLen) + alphaSeparatorLen + then + (lookupname, "", -1) (* No valid suffix in the name *) + else + (String.sub lookupname 0 (startSuffix - alphaSeparatorLen), + String.sub lookupname (startSuffix - alphaSeparatorLen) + (len - startSuffix + alphaSeparatorLen), + int_of_string (String.sub lookupname startSuffix (len - startSuffix))) + + +let getAlphaPrefix ~(lookupname:string) : string = + let p, _, _ = splitNameForAlpha ~lookupname:lookupname in + p + +(* Undoes the changes as specified by the undolist *) +let undoAlphaChanges ~(alphaTable: (string, 'a alphaTableData ref) H.t) + ~(undolist: 'a undoAlphaElement list) = + List.iter + (function + AlphaChangedSuffix (where, old) -> + where := old + | AlphaAddedSuffix name -> + if debugAlpha name then + ignore (E.log "Removing %s from alpha table\n" name); + H.remove alphaTable name) + undolist + +let docAlphaTable () (alphaTable: (string, 'a alphaTableData ref) H.t) = + let acc : (string * (int * (string * 'a) list)) list ref = ref [] in + H.iter (fun k d -> acc := (k, !d) :: !acc) alphaTable; + docList ~sep:line (fun (k, (d, _)) -> dprintf " %s -> %d" k d) () !acc + diff --git a/cil/ocamlutil/alpha.mli b/cil/ocamlutil/alpha.mli new file mode 100755 index 0000000..e1e430d --- /dev/null +++ b/cil/ocamlutil/alpha.mli @@ -0,0 +1,50 @@ +(** {b ALPHA conversion} *) + +(** This is the type of the elements that are recorded by the alpha + * conversion functions in order to be able to undo changes to the tables + * they modify. Useful for implementing + * scoping *) +type 'a undoAlphaElement + +(** This is the type of the elements of the alpha renaming table. These + * elements can carry some data associated with each occurrence of the name. *) +type 'a alphaTableData + + +(** Create a new name based on a given name. The new name is formed from a + * prefix (obtained from the given name by stripping a suffix consisting of _ + * followed by only digits), followed by a special separator and then by a + * positive integer suffix. The first argument is a table mapping name + * prefixes to some data that specifies what suffixes have been used and how + * to create the new one. This function updates the table with the new + * largest suffix generated. The "undolist" argument, when present, will be + * used by the function to record information that can be used by + * {!Alpha.undoAlphaChanges} to undo those changes. Note that the undo + * information will be in reverse order in which the action occurred. Returns + * the new name and, if different from the lookupname, the location of the + * previous occurrence. This function knows about the location implicitly + * from the {!Cil.currentLoc}. *) +val newAlphaName: alphaTable:(string, 'a alphaTableData ref) Hashtbl.t -> + undolist: 'a undoAlphaElement list ref option -> + lookupname:string -> data:'a -> string * 'a + + +(** Register a name with an alpha conversion table to ensure that when later + * we call newAlphaName we do not end up generating this one *) +val registerAlphaName: alphaTable:(string, 'a alphaTableData ref) Hashtbl.t -> + undolist: 'a undoAlphaElement list ref option -> + lookupname:string -> data:'a -> unit + +(** Split the name in preparation for newAlphaName. The prefix returned is + used to index into the hashtable. The next result value is a separator + (either empty or the separator chosen to separate the original name from + the index) *) +val docAlphaTable: unit -> + (string, 'a alphaTableData ref) Hashtbl.t -> Pretty.doc + + +val getAlphaPrefix: lookupname:string -> string + +(** Undo the changes to a table *) +val undoAlphaChanges: alphaTable:(string, 'a alphaTableData ref) Hashtbl.t -> + undolist:'a undoAlphaElement list -> unit diff --git a/cil/ocamlutil/clist.ml b/cil/ocamlutil/clist.ml new file mode 100644 index 0000000..80f0fd6 --- /dev/null +++ b/cil/ocamlutil/clist.ml @@ -0,0 +1,183 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +open Pretty + + +(* We often need to concatenate sequences and using lists for this purpose is + * expensive. So we define a kind of "concatenable lists" that are easier to + * concatenate *) +type 'a clist = + | CList of 'a list (* This is the only representation for empty + * *) + | CConsL of 'a * 'a clist + | CConsR of 'a clist * 'a + | CSeq of 'a clist * 'a clist (* We concatenate only two of them at this + * time. Neither is CEmpty. To be sure + * always use append to make these *) + +let rec listifyOnto (tail: 'a list) = function + CList l -> l @ tail + | CConsL (x, l) -> x :: listifyOnto tail l + | CConsR (l, x) -> listifyOnto (x :: tail) l + | CSeq (l1, l2) -> listifyOnto (listifyOnto tail l2) l1 + +let toList l = listifyOnto [] l +let fromList l = CList l + + +let single x = CList [x] +let empty = CList [] + +let checkBeforeAppend (l1: 'a clist) (l2: 'a clist) : bool = + l1 != l2 || l1 = (CList []) + +let append l1 l2 = + if l1 = CList [] then l2 else + if l2 = CList [] then l1 else + begin + if l1 == l2 then + raise (Failure "You should not use Clist.append to double a list"); + CSeq (l1, l2) + end + +let rec length (acc: int) = function + CList l -> acc + (List.length l) + | CConsL (x, l) -> length (acc + 1) l + | CConsR (l, _) -> length (acc + 1) l + | CSeq (l1, l2) -> length (length acc l1) l2 +let length l = length 0 l (* The external version *) + +let map (f: 'a -> 'b) (l: 'a clist) : 'b clist = + let rec loop = function + CList l -> CList (List.map f l) + | CConsL (x, l) -> let x' = f x in CConsL (x', loop l) + | CConsR (l, x) -> let l' = loop l in CConsR (l', f x) + | CSeq (l1, l2) -> let l1' = loop l1 in CSeq (l1', loop l2) + in + loop l + + +let fold_left (f: 'acc -> 'a -> 'acc) (start: 'acc) (l: 'a clist) = + let rec loop (start: 'acc) = function + CList l -> List.fold_left f start l + | CConsL (x, l) -> loop (f start x) l + | CConsR (l, x) -> let res = loop start l in f res x + | CSeq (l1, l2) -> + let res1 = loop start l1 in + loop res1 l2 + in + loop start l + +let iter (f: 'a -> unit) (l: 'a clist) : unit = + let rec loop = function + CList l -> List.iter f l + | CConsL (x, l) -> f x; loop l + | CConsR (l, x) -> loop l; f x + | CSeq (l1, l2) -> loop l1; loop l2 + in + loop l + + +let rec rev (revelem: 'a -> 'a) = function + CList l -> + let rec revonto (tail: 'a list) = function + [] -> tail + | x :: rest -> revonto (revelem x :: tail) rest + in + CList (revonto [] l) + + | CConsL (x, l) -> CConsR (rev revelem l, x) + | CConsR (l, x) -> CConsL (x, rev revelem l) + | CSeq (l1, l2) -> CSeq (rev revelem l2, rev revelem l1) + + +let docCList (sep: doc) (doone: 'a -> doc) () (dl: 'a clist) = + fold_left + (fun (acc: doc) (elem: 'a) -> + let elemd = doone elem in + if acc == nil then elemd else acc ++ sep ++ elemd) + nil + dl + + +(* let debugCheck (lst: 'a clist) : unit =*) +(* (* use a hashtable to store values encountered *)*) +(* let tbl : 'a bool H.t = (H.create 13) in*) + +(* letrec recurse (node: 'a clist) =*) +(* (* have we seen*)*) + +(* match node with*) +(* | CList*) + + +(* --------------- testing ----------------- *) +type boxedInt = + | BI of int + | SomethingElse + +let d_boxedInt () b = + match b with + | BI(i) -> (dprintf "%d" i) + | SomethingElse -> (text "somethingElse") + + +(* sm: some simple tests of CLists +let testCList () : unit = +begin + (trace "sm" (dprintf "in testCList\n")); + + let clist1 = (fromList [BI(1); BI(2); BI(3)]) in + (trace "sm" (dprintf "length of clist1 is %d\n" + (length clist1) )); + + let flattened = (toList clist1) in + (trace "sm" (dprintf "flattened: %a\n" + (docList ~sep:(chr ',' ++ break) (d_boxedInt ())) + flattened)); + + +end +1) in + (trace "sm" (dprintf "flattened: %a\n" + (docList ~sep:(chr ',' ++ break) (d_boxedInt ())) + flattened)); + + +end +*) diff --git a/cil/ocamlutil/clist.mli b/cil/ocamlutil/clist.mli new file mode 100644 index 0000000..c0378a6 --- /dev/null +++ b/cil/ocamlutil/clist.mli @@ -0,0 +1,97 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(** Utilities for managing "concatenable lists" (clists). We often need to + concatenate sequences, and using lists for this purpose is expensive. This + module provides routines to manage such lists more efficiently. In this + model, we never do cons or append explicitly. Instead we maintain + the elements of the list in a special data structure. Routines are provided + to convert to/from ordinary lists, and carry out common list operations.*) + +(** The clist datatype. A clist can be an ordinary list, or a clist preceded + or followed by an element, or two clists implicitly appended together*) +type 'a clist = + | CList of 'a list (** The only representation for the empty + list. Try to use sparingly. *) + | CConsL of 'a * 'a clist (** Do not use this a lot because scanning + * it is not tail recursive *) + | CConsR of 'a clist * 'a + | CSeq of 'a clist * 'a clist (** We concatenate only two of them at this + time. Neither is the empty clist. To be + sure always use append to make these *) + + +(** Convert a clist to an ordinary list *) +val toList: 'a clist -> 'a list + +(** Convert an ordinary list to a clist *) +val fromList: 'a list -> 'a clist + +(** Create a clist containing one element *) +val single: 'a -> 'a clist + +(** The empty clist *) +val empty: 'a clist + + +(** Append two clists *) +val append: 'a clist -> 'a clist -> 'a clist + +(** A useful check to assert before an append. It checks that the two lists + * are not identically the same (Except if they are both empty) *) +val checkBeforeAppend: 'a clist -> 'a clist -> bool + +(** Find the length of a clist *) +val length: 'a clist -> int + +(** Map a function over a clist. Returns another clist *) +val map: ('a -> 'b) -> 'a clist -> 'b clist + + +(** A version of fold_left that works on clists *) +val fold_left: ('acc -> 'a -> 'acc) -> 'acc -> 'a clist -> 'acc + +(** A version of iter that works on clists *) +val iter: ('a -> unit) -> 'a clist -> unit + +(** Reverse a clist. The first function reverses an element. *) +val rev: ('a -> 'a) -> 'a clist -> 'a clist + +(** A document for printing a clist (similar to [docList]) *) +val docCList: + Pretty.doc -> ('a -> Pretty.doc) -> unit -> 'a clist -> Pretty.doc + diff --git a/cil/ocamlutil/errormsg.ml b/cil/ocamlutil/errormsg.ml new file mode 100644 index 0000000..07e935d --- /dev/null +++ b/cil/ocamlutil/errormsg.ml @@ -0,0 +1,337 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +open Pretty + + + +let debugFlag = ref false (* If set then print debugging info *) +let verboseFlag = ref false + +(**** Error reporting ****) +exception Error +let s (d : 'a) = raise Error + +let hadErrors = ref false + +let errorContext = ref [] +let pushContext f = errorContext := f :: (!errorContext) +let popContext () = + match !errorContext with + _ :: t -> errorContext := t + | [] -> s (eprintf "Bug: cannot pop error context") + + +let withContext ctx f x = + pushContext ctx; + try + let res = f x in + popContext (); + res + with e -> begin + popContext (); + raise e + end + + (* Make sure that showContext calls + * each f with its appropriate + * errorContext as it was when it was + * pushed *) +let showContext () = + let rec loop = function + [] -> () + | f :: rest -> (errorContext := rest; (* Just in case f raises an error *) + ignore (eprintf " Context : %t@!" f); + loop rest) + in + let old = !errorContext in + try + loop old; + errorContext := old + with e -> begin + errorContext := old; + raise e + end + +let contextMessage (name: string) (d: doc) = + ignore (eprintf "@!%s: %a@!" name insert d); + showContext () + +let warnFlag = ref false + +let logChannel : out_channel ref = ref stderr + + +let bug (fmt : ('a,unit,doc,unit) format4) : 'a = + let f d = + hadErrors := true; contextMessage "Bug" d; + flush !logChannel + in + Pretty.gprintf f fmt + +let error (fmt : ('a,unit,doc,unit) format4) : 'a = + let f d = hadErrors := true; contextMessage "Error" d; + flush !logChannel + in + Pretty.gprintf f fmt + +let unimp (fmt : ('a,unit,doc,unit) format4) : 'a = + let f d = hadErrors := true; contextMessage "Unimplemented" d; + flush !logChannel + in + Pretty.gprintf f fmt + +let warn (fmt : ('a,unit,doc,unit) format4) : 'a = + let f d = contextMessage "Warning" d; flush !logChannel in + Pretty.gprintf f fmt + +let warnOpt (fmt : ('a,unit,doc,unit) format4) : 'a = + let f d = + if !warnFlag then contextMessage "Warning" d; + flush !logChannel in + Pretty.gprintf f fmt + + +let log (fmt : ('a,unit,doc,unit) format4) : 'a = + let f d = fprint !logChannel 80 d; flush !logChannel in + Pretty.gprintf f fmt + +let logg (fmt : ('a,unit,doc,unit) format4) : 'a = + let f d = fprint !logChannel 10000000 d; flush !logChannel in + Pretty.gprintf f fmt + +let null (fmt : ('a,unit,doc,unit) format4) : 'a = + let f d = () in + Pretty.gprintf f fmt + + +let theLexbuf = ref (Lexing.from_string "") + +let fail format = Pretty.gprintf (fun x -> Pretty.fprint stderr 80 x; + raise (Failure "")) format + + + +(***** Handling parsing errors ********) +type parseinfo = + { mutable linenum: int ; (* Current line *) + mutable linestart: int ; (* The position in the buffer where the + * current line starts *) + mutable fileName : string ; (* Current file *) + mutable hfile : string ; (* High-level file *) + mutable hline : int; (* High-level line *) + lexbuf : Lexing.lexbuf; + inchan : in_channel option; (* None, if from a string *) + mutable num_errors : int; (* Errors so far *) + } + +let dummyinfo = + { linenum = 1; + linestart = 0; + fileName = "" ; + lexbuf = Lexing.from_string ""; + inchan = None; + hfile = ""; + hline = 0; + num_errors = 0; + } + +let current = ref dummyinfo + +let setHLine (l: int) : unit = + !current.hline <- l +let setHFile (f: string) : unit = + !current.hfile <- f + +let rem_quotes str = String.sub str 1 ((String.length str) - 2) + +(* Change \ into / in file names. To avoid complications with escapes *) +let cleanFileName str = + let str1 = + if str <> "" && String.get str 0 = '"' (* '"' ( *) + then rem_quotes str else str in + let l = String.length str1 in + let rec loop (copyto: int) (i: int) = + if i >= l then + String.sub str1 0 copyto + else + let c = String.get str1 i in + if c <> '\\' then begin + String.set str1 copyto c; loop (copyto + 1) (i + 1) + end else begin + String.set str1 copyto '/'; + if i < l - 2 && String.get str1 (i + 1) = '\\' then + loop (copyto + 1) (i + 2) + else + loop (copyto + 1) (i + 1) + end + in + loop 0 0 + +let readingFromStdin = ref false + +let startParsing ?(useBasename=true) (fname: string) = + (* We only support one open file at a time *) + if !current != dummyinfo then begin + s (error "Errormsg.startParsing supports only one open file: You want to open %s and %s is still open\n" fname !current.fileName); + end; + let inchan = + try if fname = "-" then begin + readingFromStdin := true; + stdin + end else begin + readingFromStdin := false; + open_in fname + end + with e -> s (error "Cannot find input file %s (exception %s" + fname (Printexc.to_string e)) in + let lexbuf = Lexing.from_channel inchan in + let i = + { linenum = 1; linestart = 0; + fileName = + cleanFileName (if useBasename then Filename.basename fname else fname); + lexbuf = lexbuf; inchan = Some inchan; + hfile = ""; hline = 0; + num_errors = 0 } in + + current := i; + lexbuf + +let startParsingFromString ?(file="") ?(line=1) (str: string) = + let lexbuf = Lexing.from_string str in + let i = + { linenum = line; linestart = line - 1; + fileName = file; + hfile = ""; hline = 0; + lexbuf = lexbuf; + inchan = None; + num_errors = 0 } + in + current := i; + lexbuf + +let finishParsing () = + let i = !current in + (match i.inchan with Some c -> close_in c | _ -> ()); + current := dummyinfo + + +(* Call this function to announce a new line *) +let newline () = + let i = !current in + i.linenum <- 1 + i.linenum; + i.linestart <- Lexing.lexeme_start i.lexbuf + +let newHline () = + let i = !current in + i.hline <- 1 + i.hline + +let setCurrentLine (i: int) = + !current.linenum <- i + +let setCurrentFile (n: string) = + !current.fileName <- cleanFileName n + + +let max_errors = 20 (* Stop after 20 errors *) + +let parse_error (msg: string) : 'a = + (* Sometimes the Ocaml parser raises errors in symbol_start and symbol_end *) + let token_start, token_end = + try Parsing.symbol_start (), Parsing.symbol_end () + with e -> begin + ignore (warn "Parsing raised %s\n" (Printexc.to_string e)); + 0, 0 + end + in + let i = !current in + let adjStart = + if token_start < i.linestart then 0 else token_start - i.linestart in + let adjEnd = + if token_end < i.linestart then 0 else token_end - i.linestart in + output_string + stderr + (i.fileName ^ "[" ^ (string_of_int i.linenum) ^ ":" + ^ (string_of_int adjStart) ^ "-" + ^ (string_of_int adjEnd) + ^ "]" + ^ " : " ^ msg); + output_string stderr "\n"; + flush stderr ; + i.num_errors <- i.num_errors + 1; + if i.num_errors > max_errors then begin + output_string stderr "Too many errors. Aborting.\n" ; + exit 1 + end; + hadErrors := true; + raise Parsing.Parse_error + + + + +(* More parsing support functions: line, file, char count *) +let getPosition () : int * string * int = + let i = !current in + i.linenum, i.fileName, Lexing.lexeme_start i.lexbuf + + +let getHPosition () = + !current.hline, !current.hfile + +(** Type for source-file locations *) +type location = + { file: string; (** The file name *) + line: int; (** The line number *) + hfile: string; (** The high-level file name, or "" if not present *) + hline: int; (** The high-level line number, or 0 if not present *) + } + +let d_loc () l = + text (l.file ^ ":" ^ string_of_int l.line) + +let d_hloc () (l: location) = + dprintf "%s:%d%a" l.file l.line + insert (if l.hline > 0 then dprintf " (%s:%d)" l.hfile l.hline else nil) + +let locUnknown = { file = ""; hfile = ""; line = -1; hline = -1 } + +let getLocation () = + let hl, hf = getHPosition () in + let l, f, c = getPosition () in + { hfile = hf; hline = hl; + file = f; line = l } + diff --git a/cil/ocamlutil/errormsg.mli b/cil/ocamlutil/errormsg.mli new file mode 100644 index 0000000..8d9c697 --- /dev/null +++ b/cil/ocamlutil/errormsg.mli @@ -0,0 +1,164 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +(** Utility functions for error-reporting *) + +(** A channel for printing log messages *) +val logChannel : out_channel ref + +(** If set then print debugging info *) +val debugFlag : bool ref + +val verboseFlag : bool ref + + +(** Set to true if you want to see all warnings. *) +val warnFlag: bool ref + +(** Error reporting functions raise this exception *) +exception Error + + + (* Error reporting. All of these functions take same arguments as a + * Pretty.eprintf. They set the hadErrors flag, but do not raise an + * exception. Their return type is unit. + *) + +(** Prints an error message of the form [Error: ...]. + Use in conjunction with s, for example: [E.s (E.error ... )]. *) +val error: ('a,unit,Pretty.doc,unit) format4 -> 'a + +(** Similar to [error] except that its output has the form [Bug: ...] *) +val bug: ('a,unit,Pretty.doc,unit) format4 -> 'a + +(** Similar to [error] except that its output has the form [Unimplemented: ...] *) +val unimp: ('a,unit,Pretty.doc,unit) format4 -> 'a + +(** Stop the execution by raising an Error. *) +val s: 'a -> 'b + +(** This is set whenever one of the above error functions are called. It must + be cleared manually *) +val hadErrors: bool ref + +(** Like {!Errormsg.error} but does not raise the {!Errormsg.Error} + * exception. Return type is unit. *) +val warn: ('a,unit,Pretty.doc,unit) format4 -> 'a + +(** Like {!Errormsg.warn} but optional. Printed only if the + * {!Errormsg.warnFlag} is set *) +val warnOpt: ('a,unit,Pretty.doc,unit) format4 -> 'a + +(** Print something to [logChannel] *) +val log: ('a,unit,Pretty.doc,unit) format4 -> 'a + +(** same as {!Errormsg.log} but do not wrap lines *) +val logg: ('a,unit,Pretty.doc,unit) format4 -> 'a + + (* All of the error and warning reporting functions can also print a + * context. To register a context printing function use "pushContext". To + * remove the last registered one use "popContext". If one of the error + * reporting functions is called it will invoke all currently registered + * context reporting functions in the reverse order they were registered. *) + +(** Do not actually print (i.e. print to /dev/null) *) +val null : ('a,unit,Pretty.doc,unit) format4 -> 'a + +(** Registers a context printing function *) +val pushContext : (unit -> Pretty.doc) -> unit + +(** Removes the last registered context printing function *) +val popContext : unit -> unit + +(** Show the context stack to stderr *) +val showContext : unit -> unit + +(** To ensure that the context is registered and removed properly, use the + function below *) +val withContext : (unit -> Pretty.doc) -> ('a -> 'b) -> 'a -> 'b + + + +val newline: unit -> unit (* Call this function to announce a new line *) +val newHline: unit -> unit + +val getPosition: unit -> int * string * int (* Line number, file name, + current byte count in file *) +val getHPosition: unit -> int * string (** high-level position *) + +val setHLine: int -> unit +val setHFile: string -> unit + +val setCurrentLine: int -> unit +val setCurrentFile: string -> unit + +(** Type for source-file locations *) +type location = + { file: string; (** The file name *) + line: int; (** The line number *) + hfile: string; (** The high-level file name, or "" if not present *) + hline: int; (** The high-level line number, or 0 if not present *) + } + +val d_loc: unit -> location -> Pretty.doc +val d_hloc: unit -> location -> Pretty.doc + +val getLocation: unit -> location + +val parse_error: string -> (* A message *) + 'a + +(** An unknown location for use when you need one but you don't have one *) +val locUnknown: location + + +(** Records whether the stdin is open for reading the goal **) +val readingFromStdin: bool ref + + +(* Call this function to start parsing. useBasename is by default "true", + * meaning that the error information maintains only the basename. If the + * file name is - then it reads from stdin. *) +val startParsing: ?useBasename:bool -> string -> + Lexing.lexbuf + +val startParsingFromString: ?file:string -> ?line:int -> string + -> Lexing.lexbuf + +val finishParsing: unit -> unit (* Call this function to finish parsing and + * close the input channel *) + + diff --git a/cil/ocamlutil/growArray.ml b/cil/ocamlutil/growArray.ml new file mode 100644 index 0000000..ccadc76 --- /dev/null +++ b/cil/ocamlutil/growArray.ml @@ -0,0 +1,191 @@ +(** Growable Arrays *) + +type 'a fill = + Elem of 'a + | Susp of (int -> 'a) + +type 'a t = { + gaFill: 'a fill; + (** Stuff to use to fill in the array as it grows *) + + mutable gaMaxInitIndex: int; + (** Maximum index that was written to. -1 if no writes have + * been made. *) + + mutable gaData: 'a array; + } + +let growTheArray (ga: 'a t) (len: int) + (toidx: int) (why: string) : unit = + if toidx >= len then begin + (* Grow the array by 50% *) + let newlen = toidx + 1 + len / 2 in +(* + ignore (E.log "growing an array to idx=%d (%s)\n" toidx why); +*) + let data' = begin match ga.gaFill with + Elem x -> + let data'' = Array.create newlen x in + Array.blit ga.gaData 0 data'' 0 len; + data'' + | Susp f -> Array.init newlen + (fun i -> if i < len then ga.gaData.(i) else f i) + end + in + ga.gaData <- data' + end + +let max_init_index (ga: 'a t) : int = + ga.gaMaxInitIndex + +let num_alloc_index (ga: 'a t) : int = + Array.length ga.gaData + +let reset_max_init_index (ga: 'a t) : unit = + ga.gaMaxInitIndex <- -1 + +let getg (ga: 'a t) (r: int) : 'a = + let len = Array.length ga.gaData in + if r >= len then + growTheArray ga len r "getg"; + + ga.gaData.(r) + +let setg (ga: 'a t) (r: int) (what: 'a) : unit = + let len = Array.length ga.gaData in + if r >= len then + growTheArray ga len r "setg"; + if r > max_init_index ga then ga.gaMaxInitIndex <- r; + ga.gaData.(r) <- what + +let get (ga: 'a t) (r: int) : 'a = Array.get ga.gaData r + +let set (ga: 'a t) (r: int) (what: 'a) : unit = + if r > max_init_index ga then ga.gaMaxInitIndex <- r; + Array.set ga.gaData r what + +let make (initsz: int) (fill: 'a fill) : 'a t = + { gaFill = fill; + gaMaxInitIndex = -1; + gaData = begin match fill with + Elem x -> Array.create initsz x + | Susp f -> Array.init initsz f + end; } + +let clear (ga: 'a t) : unit = + (* This assumes the user hasn't used the raw "set" on any value past + max_init_index. Maybe we shouldn't trust max_init_index here?? *) + if ga.gaMaxInitIndex >= 0 then begin + begin match ga.gaFill with + Elem x -> Array.fill ga.gaData 0 (ga.gaMaxInitIndex+1) x + | Susp f -> + for i = 0 to ga.gaMaxInitIndex do + Array.set ga.gaData i (f i) + done + end; + ga.gaMaxInitIndex <- -1 + end + +let copy (ga: 'a t) : 'a t = + { ga with gaData = Array.copy ga.gaData } + +let deep_copy (ga: 'a t) (copy: 'a -> 'a): 'a t = + { ga with gaData = Array.map copy ga.gaData } + +(* An accumulating for loop. Used internally. *) +let fold_for ~(init: 'a) ~(lo: int) ~(hi: int) (f: int -> 'a -> 'a) = + let rec forloop i acc = + if i > hi then acc + else forloop (i+1) (f i acc) + in + forloop lo init + +(** Iterate over the initialized elements of the array *) +let iter (f: 'a -> unit) (ga: 'a t) = + for i = 0 to max_init_index ga do + f ga.gaData.(i) + done + +(** Iterate over the initialized elements of the array *) +let iteri (f: int -> 'a -> unit) (ga: 'a t) = + for i = 0 to max_init_index ga do + f i ga.gaData.(i) + done + +(** Iterate over the elements of 2 arrays *) +let iter2 (f: int -> 'a -> 'b -> unit) (ga1: 'a t) (ga2: 'b t) = + let len1 = max_init_index ga1 in + let len2 = max_init_index ga2 in + if len1 > -1 || len2 > -1 then begin + let max = if len1 > len2 then begin + ignore(getg ga2 len1); (*grow ga2 to match ga1*) + len1 + end else begin + ignore(getg ga1 len2); (*grow ga1 to match ga2*) + len2 + end in + for i = 0 to max do + f i ga1.gaData.(i) ga2.gaData.(i) + done + end + +(** Fold left over the initialized elements of the array *) +let fold_left (f: 'acc -> 'a -> 'acc) (acc: 'acc) (ga: 'a t) : 'acc = + let rec loop (acc: 'acc) (idx: int) : 'acc = + if idx > max_init_index ga then + acc + else + loop (f acc ga.gaData.(idx)) (idx + 1) + in + loop acc 0 + + +(** Fold left over the initialized elements of the array *) +let fold_lefti (f: 'acc -> int -> 'a -> 'acc) (acc: 'acc) (ga: 'a t) : 'acc = + let rec loop (acc: 'acc) (idx: int) : 'acc = + if idx > max_init_index ga then + acc + else + loop (f acc idx ga.gaData.(idx)) (idx + 1) + in + loop acc 0 + +(** Fold right over the initialized elements of the array *) +let fold_right (f: 'a -> 'acc -> 'acc) (ga: 'a t) (acc: 'acc) : 'acc = + let rec loop (acc: 'acc) (idx: int) : 'acc = + if idx < 0 then + acc + else + loop (f ga.gaData.(idx) acc) (idx - 1) + in + loop acc (max_init_index ga) + +(** Document generator *) +let d_growarray (sep: Pretty.doc) + (doit:int -> 'a -> Pretty.doc) + () + (elements: 'a t) = + Pretty.docArray ~sep:sep doit () elements.gaData + +let restoreGA ?deepCopy (ga: 'a t) : (unit -> unit) = + let old = + (match deepCopy with + None -> copy ga + | Some f -> deep_copy ga f) + in + (fun () -> + if ga.gaFill != old.gaFill then + Errormsg.s + (Errormsg.bug "restoreGA to an array with a different fill."); + ga.gaMaxInitIndex <- old.gaMaxInitIndex; + for i = 0 to max_init_index ga do + set ga i (getg old i) + done) + +let find (ga: 'a t) (fn: 'a -> bool) : int option = + let rec loop (i:int) : int option = + if i > ga.gaMaxInitIndex then None + else if fn (get ga i) then Some i + else loop (i + 1) + in + loop 0 diff --git a/cil/ocamlutil/growArray.mli b/cil/ocamlutil/growArray.mli new file mode 100644 index 0000000..4cb5f48 --- /dev/null +++ b/cil/ocamlutil/growArray.mli @@ -0,0 +1,131 @@ +(***********************************************************************) +(* Growable Arrays *) +(* *) +(* This a wrapper around the standard OCaml array, but will grow *) +(* automatically on get or set outside the current size of the *) +(* array. *) +(* *) +(* The interface is the same as the standard OCaml array where *) +(* applicable (and implemented). *) +(***********************************************************************) + +(* $Id: growArray.mli,v 1.8 2005-01-06 15:37:36 necula Exp $ *) + +(** Array operations. *) + +(** The type of growable arrays *) +type 'a t + +(** The default value to a new element of the growable array *) +type 'a fill = + Elem of 'a + (* A default value *) + | Susp of (int -> 'a) + (* A function given an index to generate a default value *) + +val make : int -> 'a fill -> 'a t +(** [GrowArray.make n x] returns a fresh growable array of size + at least [n] with default value specified by [x]. + + Raise [Invalid_argument] if [n < 0] or [n > Sys.max_array_length]. *) + +val num_alloc_index: 'a t -> int +(** [GrowArray.num_alloc_index a] returns the number of allocated entries in + * the array **) + +val max_init_index : 'a t -> int +(** [GrowArray.max_init_index a] returns the maximum index to + which has been written. + + Returns -1 if no writes have been made. *) + +val reset_max_init_index : 'a t -> unit +(** [GrowArray.reset_init a] resets the max_init_index. You should probably + use [GrowArray.clear a] instead if you also want to delete the contents. *) + +val getg : 'a t -> int -> 'a +(** [GrowArray.getg a n] returns the element number [n] of array [a]. + The first element has number 0. + The last element has number [GrowArray.length a - 1]. + + If [n] is outside the range 0 to [(GrowArray.max_init_index a)], + then the array grows to at least [n] and yields the default value. *) + +val setg : 'a t -> int -> 'a -> unit +(** [GrowArray.setg a n x] modifies array [a] in place, replacing + element number [n] with [x]. + + If [n] is outside the range 0 to [(GrowArray.max_init_index a)], + then the array grows to at least [n] and yields the default value. *) + +val get : 'a t -> int -> 'a +(** [GrowArray.get a n] returns the element number [n] of grow array [a]. + + Raise [Invalid_argument "Array.get"] if [n] is outside the range + of the underlying array. *) + +val set : 'a t -> int -> 'a -> unit +(** [GrowArray.set a n x] modifies grow array [a] in place, replacing + element number [n] with [x]. + + Raise [Invalid_argument "Array.set"] if [n] is outside the range + of the underlying array. *) + +val clear: 'a t -> unit +(** [GrowArray.clear a] clears the contents of the array and sets + max_init_index to -1. Suspension thunks will be rerun to regenerate the + initial values of the array. *) + +val copy : 'a t -> 'a t +(** [GrowArray.copy a] returns a copy of [a], that is, a fresh array + containing the same elements as [a]. *) + +val deep_copy : 'a t -> ('a -> 'a) -> 'a t +(** [GrowArray.copy a f] returns a deep copy of [a] using f to + copy elements of [a]. *) + +val iter : ('a -> unit) -> 'a t -> unit +(** [GrowArray.iter f a] applies function [f] in turn to all + the elements of [a]. It is equivalent to + [f a.(0); f a.(1); ...; f a.(GrowArray.length a - 1); ()]. *) + +val iteri : (int -> 'a -> unit) -> 'a t -> unit +(** Same as {!GrowArray.iter}, but the + function is applied to the index of the element as first argument, + and the element itself as second argument. *) + +val iter2 : (int -> 'a -> 'b -> unit) -> 'a t -> 'b t -> unit +(** Same as {!GrowArray.iteri}, but the function is applied to two arrays. + [iter2 f a b] is equivalent to + [f 0 a.(0) b.(0); f 1 a.(1) b.(1); ...; f n a.(n) b.(n); ()] + where n is the larger of (max_init_index a) or (max_init_index b). + The shorter array will grow to match the longer.*) + +val fold_left : ('a -> 'b -> 'a) -> 'a -> 'b t -> 'a +(** [GrowArray.fold_left f x a] computes + [f (... (f (f x a.(0)) a.(1)) ...) a.(n-1)], + where [n] is the length of the array [a]. *) + +val fold_lefti : ('a -> int -> 'b -> 'a) -> 'a -> 'b t -> 'a +(** [GrowArray.fold_lefti f x a] computes + [f (... (f (f x 0 a.(0)) 1 a.(1)) ...) (n-1) a.(n-1)], + where [n] is the length of the array [a]. *) + +val fold_right : ('b -> 'a -> 'a) -> 'b t -> 'a -> 'a +(** [GrowArray.fold_right f a x] computes + [f a.(0) (f a.(1) ( ... (f a.(n-1) x) ...))], + where [n] is the length of the array [a]. *) + +val d_growarray : Pretty.doc -> (int -> 'a -> Pretty.doc) -> unit -> 'a t + -> Pretty.doc +(** [GrowArray.d_growarray sep f () a] creates a {!Pretty.doc} for growable + array a using separator sep and element printer f. *) + + +val restoreGA: ?deepCopy:('a -> 'a) -> 'a t -> unit -> unit +(** Given a growable array, produce a thunk that later restores it to its + current value *) + +val find: 'a t -> ('a -> bool) -> int option +(** Returns the index of the first element in the array that satisfies the + predicate, or None if there is no such element *) diff --git a/cil/ocamlutil/inthash.ml b/cil/ocamlutil/inthash.ml new file mode 100755 index 0000000..b1ad0c0 --- /dev/null +++ b/cil/ocamlutil/inthash.ml @@ -0,0 +1,188 @@ +(** A hash table specialized on integer keys *) +type 'a t = + { mutable size: int; (* number of elements *) + mutable data: 'a bucketlist array } (* the buckets *) + +and 'a bucketlist = + Empty + | Cons of int * 'a * 'a bucketlist + +let hash key = key land 0x3fffffff + +let create initial_size = + let s = min (max 1 initial_size) Sys.max_array_length in + { size = 0; data = Array.make s Empty } + +let clear h = + for i = 0 to Array.length h.data - 1 do + h.data.(i) <- Empty + done; + h.size <- 0 + +let copy h = + { size = h.size; + data = Array.copy h.data } + +let copy_into src dest = + dest.size <- src.size; + dest.data <- Array.copy src.data + +let length h = h.size + +let resize tbl = + let odata = tbl.data in + let osize = Array.length odata in + let nsize = min (2 * osize + 1) Sys.max_array_length in + if nsize <> osize then begin + let ndata = Array.create nsize Empty in + let rec insert_bucket = function + Empty -> () + | Cons(key, data, rest) -> + insert_bucket rest; (* preserve original order of elements *) + let nidx = (hash key) mod nsize in + ndata.(nidx) <- Cons(key, data, ndata.(nidx)) in + for i = 0 to osize - 1 do + insert_bucket odata.(i) + done; + tbl.data <- ndata; + end + +let add h key info = + let i = (hash key) mod (Array.length h.data) in + let bucket = Cons(key, info, h.data.(i)) in + h.data.(i) <- bucket; + h.size <- succ h.size; + if h.size > Array.length h.data lsl 1 then resize h + +let remove h key = + let rec remove_bucket = function + Empty -> + Empty + | Cons(k, i, next) -> + if k = key + then begin h.size <- pred h.size; next end + else Cons(k, i, remove_bucket next) in + let i = (hash key) mod (Array.length h.data) in + h.data.(i) <- remove_bucket h.data.(i) + +let remove_all h key = + let rec remove_bucket = function + Empty -> + Empty + | Cons(k, i, next) -> + if k = key + then begin h.size <- pred h.size; + remove_bucket next end + else Cons(k, i, remove_bucket next) in + let i = (hash key) mod (Array.length h.data) in + h.data.(i) <- remove_bucket h.data.(i) + +let rec find_rec key = function + Empty -> + raise Not_found + | Cons(k, d, rest) -> + if key = k then d else find_rec key rest + +let find h key = + match h.data.((hash key) mod (Array.length h.data)) with + Empty -> raise Not_found + | Cons(k1, d1, rest1) -> + if key = k1 then d1 else + match rest1 with + Empty -> raise Not_found + | Cons(k2, d2, rest2) -> + if key = k2 then d2 else + match rest2 with + Empty -> raise Not_found + | Cons(k3, d3, rest3) -> + if key = k3 then d3 else find_rec key rest3 + +let find_all h key = + let rec find_in_bucket = function + Empty -> + [] + | Cons(k, d, rest) -> + if k = key then d :: find_in_bucket rest else find_in_bucket rest in + find_in_bucket h.data.((hash key) mod (Array.length h.data)) + +let replace h key info = + let rec replace_bucket = function + Empty -> + raise Not_found + | Cons(k, i, next) -> + if k = key + then Cons(k, info, next) + else Cons(k, i, replace_bucket next) in + let i = (hash key) mod (Array.length h.data) in + let l = h.data.(i) in + try + h.data.(i) <- replace_bucket l + with Not_found -> + h.data.(i) <- Cons(key, info, l); + h.size <- succ h.size; + if h.size > Array.length h.data lsl 1 then resize h + +let mem h key = + let rec mem_in_bucket = function + | Empty -> + false + | Cons(k, d, rest) -> + k = key || mem_in_bucket rest in + mem_in_bucket h.data.((hash key) mod (Array.length h.data)) + +let iter (f: int -> 'a -> unit) (h: 'a t) : unit = + let rec do_bucket = function + Empty -> + () + | Cons(k, d, rest) -> + f k d; do_bucket rest in + let d = h.data in + for i = 0 to Array.length d - 1 do + do_bucket d.(i) + done + +let fold (f: int -> 'a -> 'b -> 'b) (h: 'a t) (init: 'b) = + let rec do_bucket b accu = + match b with + Empty -> + accu + | Cons(k, d, rest) -> + do_bucket rest (f k d accu) in + let d = h.data in + let accu = ref init in + for i = 0 to Array.length d - 1 do + accu := do_bucket d.(i) !accu + done; + !accu + + +let memoize (h: 'a t) (key: int) (f: int -> 'a) : 'a = + let i = (hash key) mod (Array.length h.data) in + let rec find_rec key = function + Empty -> addit () + | Cons(k, d, rest) -> + if key = k then d else find_rec key rest + and find_in_bucket key = function + Empty -> addit () + | Cons(k1, d1, rest1) -> + if key = k1 then d1 else + match rest1 with + Empty -> addit () + | Cons(k2, d2, rest2) -> + if key = k2 then d2 else + match rest2 with + Empty -> addit () + | Cons(k3, d3, rest3) -> + if key = k3 then d3 else find_rec key rest3 + and addit () = + let it = f key in + h.data.(i) <- Cons(key, it, h.data.(i)); + h.size <- succ h.size; + if h.size > Array.length h.data lsl 1 then resize h; + it + in + find_in_bucket key h.data.(i) + + +let tolist (h: 'a t) : (int * 'a) list = + fold (fun k d acc -> (k, d) :: acc) h [] diff --git a/cil/ocamlutil/inthash.mli b/cil/ocamlutil/inthash.mli new file mode 100755 index 0000000..f62fcd2 --- /dev/null +++ b/cil/ocamlutil/inthash.mli @@ -0,0 +1,27 @@ +type 'a t + +(* These functions behave the same as Hashtbl, but the key type is + always int. (Specializing on int improves the performance) *) + +val create: int -> 'a t +val clear: 'a t -> unit +val length : 'a t -> int + +val copy: 'a t -> 'a t +val copy_into: 'a t -> 'a t -> unit + +val add: 'a t -> int -> 'a -> unit +val replace: 'a t -> int -> 'a -> unit +val remove: 'a t -> int -> unit +val remove_all: 'a t -> int -> unit + +val mem: 'a t -> int -> bool +val find: 'a t -> int -> 'a +val find_all: 'a t -> int -> 'a list + +val iter: (int -> 'a -> unit) -> 'a t -> unit +val fold: (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + +val memoize: 'a t -> int -> (int -> 'a) -> 'a + +val tolist: 'a t -> (int * 'a) list diff --git a/cil/ocamlutil/intmap.ml b/cil/ocamlutil/intmap.ml new file mode 100755 index 0000000..00242bc --- /dev/null +++ b/cil/ocamlutil/intmap.ml @@ -0,0 +1,171 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id: intmap.ml,v 1.2 2005-10-04 21:30:25 necula Exp $ *) + +(* specialized to integer keys by George Necula *) + +type 'a t = + Empty + | Node of 'a t * int * 'a * 'a t * int + +let height = function + Empty -> 0 + | Node(_,_,_,_,h) -> h + +let create l x d r = + let hl = height l and hr = height r in + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + +let bal l x d r = + let hl = match l with Empty -> 0 | Node(_,_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,_,h) -> h in + if hl > hr + 2 then begin + match l with + Empty -> invalid_arg "Map.bal" + | Node(ll, lv, ld, lr, _) -> + if height ll >= height lr then + create ll lv ld (create lr x d r) + else begin + match lr with + Empty -> invalid_arg "Map.bal" + | Node(lrl, lrv, lrd, lrr, _)-> + create (create ll lv ld lrl) lrv lrd (create lrr x d r) + end + end else if hr > hl + 2 then begin + match r with + Empty -> invalid_arg "Map.bal" + | Node(rl, rv, rd, rr, _) -> + if height rr >= height rl then + create (create l x d rl) rv rd rr + else begin + match rl with + Empty -> invalid_arg "Map.bal" + | Node(rll, rlv, rld, rlr, _) -> + create (create l x d rll) rlv rld (create rlr rv rd rr) + end + end else + Node(l, x, d, r, (if hl >= hr then hl + 1 else hr + 1)) + +let empty = Empty + +let is_empty = function Empty -> true | _ -> false + +let rec add x data = function + Empty -> + Node(Empty, x, data, Empty, 1) + | Node(l, v, d, r, h) as t -> + if x = v then + Node(l, x, data, r, h) + else if x < v then + bal (add x data l) v d r + else + bal l v d (add x data r) + +let rec find x = function + Empty -> + raise Not_found + | Node(l, v, d, r, _) -> + if x = v then d + else find x (if x < v then l else r) + +let rec mem x = function + Empty -> + false + | Node(l, v, d, r, _) -> + x = v || mem x (if x < v then l else r) + +let rec min_binding = function + Empty -> raise Not_found + | Node(Empty, x, d, r, _) -> (x, d) + | Node(l, x, d, r, _) -> min_binding l + +let rec remove_min_binding = function + Empty -> invalid_arg "Map.remove_min_elt" + | Node(Empty, x, d, r, _) -> r + | Node(l, x, d, r, _) -> bal (remove_min_binding l) x d r + +let merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (_, _) -> + let (x, d) = min_binding t2 in + bal t1 x d (remove_min_binding t2) + +let rec remove x = function + Empty -> + Empty + | Node(l, v, d, r, h) as t -> + if x = v then + merge l r + else if x < v then + bal (remove x l) v d r + else + bal l v d (remove x r) + +let rec iter f = function + Empty -> () + | Node(l, v, d, r, _) -> + iter f l; f v d; iter f r + +let rec map f = function + Empty -> Empty + | Node(l, v, d, r, h) -> Node(map f l, v, f d, map f r, h) + +let rec mapi f = function + Empty -> Empty + | Node(l, v, d, r, h) -> Node(mapi f l, v, f v d, mapi f r, h) + +let rec fold f m accu = + match m with + Empty -> accu + | Node(l, v, d, r, _) -> + fold f l (f v d (fold f r accu)) + +type 'a enumeration = End | More of int * 'a * 'a t * 'a enumeration + +let rec cons_enum m e = + match m with + Empty -> e + | Node(l, v, d, r, _) -> cons_enum l (More(v, d, r, e)) + +let compare cmp m1 m2 = + let rec compare_aux e1 e2 = + match (e1, e2) with + (End, End) -> 0 + | (End, _) -> -1 + | (_, End) -> 1 + | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> + if v1 <> v2 then if v1 < v2 then -1 else 1 else + let c = cmp d1 d2 in + if c <> 0 then c else + compare_aux (cons_enum r1 e1) (cons_enum r2 e2) +in compare_aux (cons_enum m1 End) (cons_enum m2 End) + +let equal cmp m1 m2 = + let rec equal_aux e1 e2 = + match (e1, e2) with + (End, End) -> true + | (End, _) -> false + | (_, End) -> false + | (More(v1, d1, r1, e1), More(v2, d2, r2, e2)) -> + v1 = v2 && cmp d1 d2 && + equal_aux (cons_enum r1 e1) (cons_enum r2 e2) +in equal_aux (cons_enum m1 End) (cons_enum m2 End) + +(** Some definitions for ML2Coq *) +let _ = ignore "coq: +(* Some definitions for ML2Coq *) + +" diff --git a/cil/ocamlutil/intmap.mli b/cil/ocamlutil/intmap.mli new file mode 100755 index 0000000..eef89b5 --- /dev/null +++ b/cil/ocamlutil/intmap.mli @@ -0,0 +1,87 @@ +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id: intmap.mli,v 1.1 2005-02-28 16:24:00 necula Exp $ *) + +(** Specialized to integer keys by George Necula *) + +(** Association tables over ordered types. + + This module implements applicative association tables, also known as + finite maps or dictionaries, given a total ordering function + over the keys. + All operations over maps are purely applicative (no side-effects). + The implementation uses balanced binary trees, and therefore searching + and insertion take time logarithmic in the size of the map. +*) + +type (+'a) t + (** The type of maps from type [key] to type ['a]. *) + +val empty: 'a t + (** The empty map. *) + +val is_empty: 'a t -> bool + (** Test whether a map is empty or not. *) + +val add: int -> 'a -> 'a t -> 'a t + (** [add x y m] returns a map containing the same bindings as + [m], plus a binding of [x] to [y]. If [x] was already bound + in [m], its previous binding disappears. *) + +val find: int -> 'a t -> 'a + (** [find x m] returns the current binding of [x] in [m], + or raises [Not_found] if no such binding exists. *) + +val remove: int -> 'a t -> 'a t + (** [remove x m] returns a map containing the same bindings as + [m], except for [x] which is unbound in the returned map. *) + +val mem: int -> 'a t -> bool + (** [mem x m] returns [true] if [m] contains a binding for [x], + and [false] otherwise. *) + +val iter: (int -> 'a -> unit) -> 'a t -> unit + (** [iter f m] applies [f] to all bindings in map [m]. + [f] receives the key as first argument, and the associated value + as second argument. The bindings are passed to [f] in increasing + order with respect to the ordering over the type of the keys. + Only current bindings are presented to [f]: + bindings hidden by more recent bindings are not passed to [f]. *) + +val map: ('a -> 'b) -> 'a t -> 'b t + (** [map f m] returns a map with same domain as [m], where the + associated value [a] of all bindings of [m] has been + replaced by the result of the application of [f] to [a]. + The bindings are passed to [f] in increasing order + with respect to the ordering over the type of the keys. *) + +val mapi: (int -> 'a -> 'b) -> 'a t -> 'b t + (** Same as {!Map.S.map}, but the function receives as arguments both the + key and the associated value for each binding of the map. *) + +val fold: (int -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** [fold f m a] computes [(f kN dN ... (f k1 d1 a)...)], + where [k1 ... kN] are the keys of all bindings in [m] + (in increasing order), and [d1 ... dN] are the associated data. *) + +val compare: ('a -> 'a -> int) -> 'a t -> 'a t -> int + (** Total ordering between maps. The first argument is a total ordering + used to compare data associated with equal keys in the two maps. *) + +val equal: ('a -> 'a -> bool) -> 'a t -> 'a t -> bool + (** [equal cmp m1 m2] tests whether the maps [m1] and [m2] are + equal, that is, contain equal keys and associate them with + equal data. [cmp] is the equality predicate used to compare + the data associated with the keys. *) + diff --git a/cil/ocamlutil/perfcount.c.in b/cil/ocamlutil/perfcount.c.in new file mode 100755 index 0000000..ae532f6 --- /dev/null +++ b/cil/ocamlutil/perfcount.c.in @@ -0,0 +1,184 @@ +// -*- Mode: c -*- +// +/* + * A module that allows the reading of performance counters on Pentium. + * + * This file contains both code that uses the performance counters to + * compute the number of cycles per second (to be used during ./configure) + * and also code to read the performance counters from Ocaml. + * + * Author: George Necula (necula@cs.berkeley.edu) + */ +#include +#include +#include + +#if defined(__GNUC__) + #define longlong long long + // RDTSC puts the result in EAX and EDX. We tell gcc to use those registers + // for "low" and "high" + #if defined(__i386__) + #define GETCOUNTER(low,high) \ + __asm__ volatile ("rdtsc" : "=a" (low), "=d" (high)); + #else + #define GETCOUNTER(low,high) \ + printf ("Reading of performance counters is supported only on Intel x86\n"); \ + exit(1); + #endif +#else + // Microsoft Visual Studio + #define longlong __int64 + #define inline __inline + #define GETCOUNTER(low,high) __asm { \ + __asm rdtsc \ + __asm mov low, eax \ + __asm mov high, edx }; +#endif + +/* Store here the first value read from the performance counter */ +unsigned static longlong first_value; + + +/* This is the function that actually reads the performance counter. */ +inline unsigned longlong read_ppc(void) { + unsigned long pclow, pchigh; + unsigned longlong lowhigh; + + GETCOUNTER(pclow, pchigh); + + // printf ("Read low=0x%08lx high=0x%08lx\n", low, high); + + // Put the 64-bit value together + lowhigh = ((unsigned longlong)pclow) | ((unsigned longlong)pchigh << 32); + + if(first_value == 0) { + first_value = lowhigh; + } + return lowhigh - first_value; +} + + +/* sm: I want a version that is as fast as possible, dropping + * bits that aren't very important to achieve it. * + * + * This version drops the low 20 bits and the high 14 bits so the + * result is 30 bits (always a positive Ocaml int); this yields + * megacycles, which for GHz machines will be something like + * milliseconds. */ +static unsigned long sample_ppc_20(void) +{ + unsigned long pclow, pchigh; + + GETCOUNTER(pclow, pchigh); + + return ((pclow >> 20) | (pchigh << 12)) & 0x3FFFFFFF; +} + +/* This version drops the low 10 bits, yielding something like + * microseconds. */ +inline static unsigned long sample_ppc_10() +{ + unsigned long pclow, pchigh; + + GETCOUNTER(pclow,pchigh); + + return ((pclow >> 10) | (pchigh << 22)) & 0x3FFFFFFF; +} + + + +#ifndef CONFIGURATION_ONLY +/*** This is the OCAML stub for the read_ppc ***/ +#include +#include +#include + +#define CYCLES_PER_USEC @CYCLES_PER_USEC@ +value read_pentium_perfcount() +{ + double counter = (double)read_ppc() / (1000000.0 * CYCLES_PER_USEC); + return copy_double(counter); +} + +/* The Ocaml system can use this function to figure out if there are + * performance counters available */ +value has_performance_counters() { + // HAS_PERFCOUNT is set by the configuration code at the end of + // this file, during ./configure +#if @HAS_PERFCOUNT@ != 0 + return Val_true; +#else + return Val_false; +#endif +} + +/* sm: interface to above from Ocaml */ +value sample_pentium_perfcount_20() +{ + return Val_long(sample_ppc_20()); +} + +value sample_pentium_perfcount_10() +{ + return Val_long(sample_ppc_10()); +} + +#endif + + +/* Now we have a function that tries to compute the number of cycles per + * second (to be used during ./configure) */ +#ifdef CONFIGURATION_ONLY +#include +#include +#include + +int main() { + struct tms t; + clock_t start, finish, diff; + unsigned longlong start_pc, finish_pc, diff_pc; + long clk_per_sec = sysconf(_SC_CLK_TCK); + double cycles_per_usec; + + if(clk_per_sec <= 0) { + printf("Cannot find clk_per_sec (got %ld)\n", clk_per_sec); + exit(1); + } + + times(&t); start = t.tms_utime; + start_pc = read_ppc(); + // Do something for a while + { + int i; + double a = 5.678; + for(i=0;i<10000000;i++) { + a = (i & 1) ? (a * a) : (sqrt(a)); + } + } + times(&t); finish = t.tms_utime; + finish_pc = read_ppc(); + diff = finish - start; + diff_pc = finish_pc - start_pc; + if(diff == 0) { + printf("Cannot use Unix.times\n"); + exit(1); + } + if(diff_pc == 0) { + printf("Invalid result from the peformance counters\n"); + exit(1); + } + diff_pc /= 1000000; // We care about cycles per microsecond +// printf("diff = %ld, diff_pc = %ld, clk = %ld\n", +// (long)diff, +// (long)diff_pc, (long)clk_per_sec); + + cycles_per_usec = (((double)diff_pc / (double)diff) + * (double)clk_per_sec); + + /* Whatever value we print here will be used as the CYCLES_PER_USEC + * below */ + printf("%.3lf\n", cycles_per_usec); + exit(0); +} +#endif //defined CONFIGURATION_ONLY + diff --git a/cil/ocamlutil/pretty.ml b/cil/ocamlutil/pretty.ml new file mode 100644 index 0000000..47d07ac --- /dev/null +++ b/cil/ocamlutil/pretty.ml @@ -0,0 +1,859 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(******************************************************************************) +(* Pretty printer + This module contains several fast, but sub-optimal heuristics to pretty-print + structured text. +*) + +let debug = false + +(* Choose an algorithm *) +type algo = George | Aman | Gap +let algo = George +let fastMode = ref false + + +(** Whether to print identation or not (for faster printing and smaller + * output) *) +let printIndent = ref true + +(******************************************************************************) +(* The doc type and constructors *) + +type doc = + Nil + | Text of string + | Concat of doc * doc + | CText of doc * string + | Break + | Line + | LeftFlush + | Align + | Unalign + | Mark + | Unmark + +(* Break a string at \n *) +let rec breakString (acc: doc) (str: string) : doc = + try + (* Printf.printf "breaking string %s\n" str; *) + let r = String.index str '\n' in + (* Printf.printf "r=%d\n" r; *) + let len = String.length str in + if r > 0 then begin + (* Printf.printf "Taking %s\n" (String.sub str 0 r); *) + let acc' = Concat(CText (acc, String.sub str 0 r), Line) in + if r = len - 1 then (* The last one *) + acc' + else begin + (* Printf.printf "Continuing with %s\n" (String.sub str (r + 1) (len - r - 1)); *) + breakString acc' + (String.sub str (r + 1) (len - r - 1)) + end + end else (* The first is a newline *) + breakString (Concat(acc, Line)) + (String.sub str (r + 1) (len - r - 1)) + with Not_found -> + if acc = Nil then Text str else CText (acc, str) + +let nil = Nil +let text s = breakString nil s +let num i = text (string_of_int i) +let real f = text (string_of_float f) +let chr c = text (String.make 1 c) +let align = Align +let unalign = Unalign +let line = Line +let leftflush = LeftFlush +let break = Break +let mark = Mark +let unmark = Unmark + +let d_int32 (i: int32) = text (Int32.to_string i) +let f_int32 () i = d_int32 i + +let d_int64 (i: int64) = text (Int64.to_string i) +let f_int64 () i = d_int64 i + + +(* Note that the ++ operator in Ocaml are left-associative. This means + * that if you have a long list of ++ then the whole thing is very unbalanced + * towards the left side. This is the worst possible case since scanning the + * left side of a Concat is the non-tail recursive case. *) + +let (++) d1 d2 = Concat (d1, d2) +let concat d1 d2 = Concat (d1, d2) + +(* Ben Liblit fix *) +let indent n d = text (String.make n ' ') ++ (align ++ (d ++ unalign)) + +let markup d = mark ++ d ++ unmark + +(* Format a sequence. The first argument is a separator *) +let seq ~(sep:doc) ~(doit:'a -> doc) ~(elements: 'a list) = + let rec loop (acc: doc) = function + [] -> acc + | h :: t -> + let fh = doit h in (* Make sure this is done first *) + loop (acc ++ sep ++ fh) t + in + (match elements with + [] -> nil + | h :: t -> + let fh = doit h in loop fh t) + + +let docArray ?(sep=chr ',') (doit:int -> 'a -> doc) () (elements:'a array) = + let len = Array.length elements in + if len = 0 then + nil + else + let rec loop (acc: doc) i = + if i >= len then acc else + let fi = doit i elements.(i) in (* Make sure this is done first *) + loop (acc ++ sep ++ fi) (i + 1) + in + let f0 = doit 0 elements.(0) in + loop f0 1 + +let docOpt delem () = function + None -> text "None" + | Some e -> text "Some(" ++ (delem e) ++ chr ')' + + + +let docList ?(sep=chr ',') (doit:'a -> doc) () (elements:'a list) = + seq sep doit elements + +let insert () d = d + + +let d_list (sep:string) (doit:unit -> 'a -> doc) () (elts:'a list) : doc = + (* thunk 'doit' to match docList's interface *) + let internalDoit (elt:'a) = + (doit () elt) in + (docList ~sep:(text sep) internalDoit () elts) + +(** Format maps *) +module MakeMapPrinter = + functor (Map: sig + type key + type 'a t + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + end) -> +struct + let docMap ?(sep=chr ',') + (doit: Map.key -> 'a -> doc) () (maplets: 'a Map.t) : doc = + Map.fold + (fun k d acc -> + (if acc==nil then acc else acc ++ sep) + ++ (doit k d)) + maplets + nil + + let dmaplet d0 d1 = d0 ++ (text " |-> ") ++ d1 + + let d_map ?(dmaplet=dmaplet) (sep:string) dkey dval = + let doit = fun k d -> dmaplet (dkey () k) (dval () d) in + docMap ~sep:(text sep) doit +end + +(** Format sets *) +module MakeSetPrinter = + functor (Set: sig + type elt + type t + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + end) -> +struct + let docSet ?(sep=chr ',') (doit: Set.elt -> doc) () (set: Set.t) : doc = + Set.fold + (fun elt acc -> + (if acc==nil then acc else acc ++ sep) + ++ (doit elt)) + set + nil + + let d_set (sep:string) delt = + docSet ~sep:(text sep) (delt ()) +end + + +(******************************************************************************) +(* Some debugging stuff *) + +let dbgprintf x = Printf.fprintf stderr x + +let rec dbgPrintDoc = function + Nil -> dbgprintf "(Nil)" + | Text s -> dbgprintf "(Text %s)" s + | Concat (d1,d2) -> dbgprintf ""; dbgPrintDoc d1; dbgprintf " ++\n "; + dbgPrintDoc d2; dbgprintf "" + | CText (d,s) -> dbgPrintDoc d; dbgprintf " ++ \"%s\"" s; + | Break -> dbgprintf "(Break)" + | Line -> dbgprintf "(Line)" + | LeftFlush -> dbgprintf "(LeftFlush)" + | Align -> dbgprintf "(Align)" + | Unalign -> dbgprintf "(Unalign)" + | Mark -> dbgprintf "(Mark)" + | Unmark -> dbgprintf "(Unmark)" + +(******************************************************************************) +(* The "george" algorithm *) + +(* When we construct documents, most of the time they are heavily unbalanced + * towards the left. This is due to the left-associativity of ++ and also to + * the fact that constructors such as docList construct from the let of a + * sequence. We would prefer to shift the imbalance to the right to avoid + * consuming a lot of stack when we traverse the document *) +let rec flatten (acc: doc) = function + | Concat (d1, d2) -> flatten (flatten acc d2) d1 + | CText (d, s) -> flatten (Concat(Text s, acc)) d + | Nil -> acc (* Get rid of Nil *) + | d -> Concat(d, acc) + +(* We keep a stack of active aligns. *) +type align = + { mutable gainBreak: int; (* This is the gain that is associated with + * taking the break associated with this + * alignment mark. If this is 0, then there + * is no break associated with the mark *) + mutable isTaken: bool ref; (* If breakGain is > 0 then this is a ref + * cell that must be set to true when the + * break is taken. These ref cells are also + * int the "breaks" list *) + deltaFromPrev: int ref; (* The column of this alignment mark - + * the column of the previous mark. + * Shared with the deltaToNext of the + * previous active align *) + deltaToNext: int ref (* The column of the next alignment mark - + * the columns of this one. Shared with + * deltaFromPrev of the next active align *) + } + +(* We use references to avoid the need to pass data around all the time *) +let aligns: align list ref = (* The current stack of active alignment marks, + * with the top at the head. Never empty. *) + ref [{ gainBreak = 0; isTaken = ref false; + deltaFromPrev = ref 0; deltaToNext = ref 0; }] + +let topAlignAbsCol = ref 0 (* The absolute column of the top alignment *) + +let pushAlign (abscol: int) = + let topalign = List.hd !aligns in + let res = + { gainBreak = 0; isTaken = ref false; + deltaFromPrev = topalign.deltaToNext; (* Share with the previous *) + deltaToNext = ref 0; (* Allocate a new ref *)} in + aligns := res :: !aligns; + res.deltaFromPrev := abscol - !topAlignAbsCol; + topAlignAbsCol := abscol + +let popAlign () = + match !aligns with + top :: t when t != [] -> + aligns := t; + topAlignAbsCol := !topAlignAbsCol - !(top.deltaFromPrev) + | _ -> failwith "Unmatched unalign\n" + +(** We keep a list of active markup sections. For each one we keep the column + * we are in *) +let activeMarkups: int list ref = ref [] + + +(* Keep a list of ref cells for the breaks, in the same order that we see + * them in the document *) +let breaks: bool ref list ref = ref [] + +(* The maximum column that we should use *) +let maxCol = ref 0 + +(* Sometimes we take all the optional breaks *) +let breakAllMode = ref false + +(* We are taking a newline and moving left *) +let newline () = + let topalign = List.hd !aligns in (* aligns is never empty *) + if debug then + dbgprintf "Taking a newline: reseting gain of %d\n" topalign.gainBreak; + topalign.gainBreak <- 0; (* Erase the current break info *) + if !breakAllMode && !topAlignAbsCol < !maxCol then + breakAllMode := false; + !topAlignAbsCol (* This is the new column *) + + + +(* Choose the align with the best gain. We outght to find a better way to + * keep the aligns sorted, especially since they gain never changes (when the + * align is the top align) *) +let chooseBestGain () : align option = + let bestGain = ref 0 in + let rec loop (breakingAlign: align option) = function + [] -> breakingAlign + | a :: resta -> + if debug then dbgprintf "Looking at align with gain %d\n" a.gainBreak; + if a.gainBreak > !bestGain then begin + bestGain := a.gainBreak; + loop (Some a) resta + end else + loop breakingAlign resta + in + loop None !aligns + + +(* Another one that chooses the break associated with the current align only *) +let chooseLastGain () : align option = + let topalign = List.hd !aligns in + if topalign.gainBreak > 0 then Some topalign else None + +(* We have just advanced to a new column. See if we must take a line break *) +let movingRight (abscol: int) : int = + (* Keep taking the best break until we get back to the left of maxCol or no + * more are left *) + let rec tryAgain abscol = + if abscol <= !maxCol then abscol else + begin + if debug then + dbgprintf "Looking for a break to take in column %d\n" abscol; + (* Find the best gain there is out there *) + match if !fastMode then None else chooseBestGain () with + None -> begin + (* No breaks are available. Take all breaks from now on *) + breakAllMode := true; + if debug then + dbgprintf "Can't find any breaks\n"; + abscol + end + | Some breakingAlign -> begin + let topalign = List.hd !aligns in + let theGain = breakingAlign.gainBreak in + assert (theGain > 0); + if debug then dbgprintf "Taking break at %d. gain=%d\n" abscol theGain; + breakingAlign.isTaken := true; + breakingAlign.gainBreak <- 0; + if breakingAlign != topalign then begin + breakingAlign.deltaToNext := + !(breakingAlign.deltaToNext) - theGain; + topAlignAbsCol := !topAlignAbsCol - theGain + end; + tryAgain (abscol - theGain) + end + end + in + tryAgain abscol + + +(* Keep track of nested align in gprintf. Each gprintf format string must + * have properly nested align/unalign pairs. When the nesting depth surpasses + * !printDepth then we print ... and we skip until the matching unalign *) +let printDepth = ref 10000000 (* WRW: must see whole thing *) +let alignDepth = ref 0 + +let useAlignDepth = true + +(** Start an align. Return true if we ahve just passed the threshhold *) +let enterAlign () = + incr alignDepth; + useAlignDepth && !alignDepth = !printDepth + 1 + +(** Exit an align *) +let exitAlign () = + decr alignDepth + +(** See if we are at a low-enough align level (and we should be printing + * normally) *) +let shallowAlign () = + not useAlignDepth || !alignDepth <= !printDepth + + +(* Pass the current absolute column and compute the new column *) +let rec scan (abscol: int) (d: doc) : int = + match d with + Nil -> abscol + | Concat (d1, d2) -> scan (scan abscol d1) d2 + | Text s when shallowAlign () -> + let sl = String.length s in + if debug then + dbgprintf "Done string: %s from %d to %d\n" s abscol (abscol + sl); + movingRight (abscol + sl) + | CText (d, s) -> + let abscol' = scan abscol d in + if shallowAlign () then begin + let sl = String.length s in + if debug then + dbgprintf "Done string: %s from %d to %d\n" s abscol' (abscol' + sl); + movingRight (abscol' + sl) + end else + abscol' + + | Align -> + pushAlign abscol; + if enterAlign () then + movingRight (abscol + 3) (* "..." *) + else + abscol + + | Unalign -> exitAlign (); popAlign (); abscol + + | Line when shallowAlign () -> (* A forced line break *) + if !activeMarkups != [] then + failwith "Line breaks inside markup sections"; + newline () + + | LeftFlush when shallowAlign () -> (* Keep cursor left-flushed *) 0 + + | Break when shallowAlign () -> (* An optional line break. Always a space + * followed by an optional line break *) + if !activeMarkups != [] then + failwith "Line breaks inside markup sections"; + let takenref = ref false in + breaks := takenref :: !breaks; + let topalign = List.hd !aligns in (* aligns is never empty *) + if !breakAllMode then begin + takenref := true; + newline () + end else begin + (* If there was a previous break there it stays not taken, forever. + * So we overwrite it. *) + topalign.isTaken <- takenref; + topalign.gainBreak <- 1 + abscol - !topAlignAbsCol; + if debug then + dbgprintf "Registering a break at %d with gain %d\n" + (1 + abscol) topalign.gainBreak; + movingRight (1 + abscol) + end + + | Mark -> activeMarkups := abscol :: !activeMarkups; + abscol + + | Unmark -> begin + match !activeMarkups with + old :: rest -> activeMarkups := rest; + old + | [] -> failwith "Too many unmark" + end + + | _ -> (* Align level is too deep *) abscol + + +(** Keep a running counter of the newlines we are taking. You can read and + * reset this from user code, if you want *) +let countNewLines = ref 0 + +(* The actual function that takes a document and prints it *) +let emitDoc + (emitString: string -> int -> unit) (* emit a number of copies of a + * string *) + (d: doc) = + let aligns: int list ref = ref [0] in (* A stack of alignment columns *) + + let wantIndent = ref false in + (* Use this function to take a newline *) + (* AB: modified it to flag wantIndent. The actual indentation is done only + if leftflush is not encountered *) + let newline () = + match !aligns with + [] -> failwith "Ran out of aligns" + | x :: _ -> + emitString "\n" 1; + incr countNewLines; + wantIndent := true; + x + in + (* Print indentation if wantIndent was previously flagged ; reset this flag *) + let indentIfNeeded () = + if !printIndent && !wantIndent then ignore ( + match !aligns with + [] -> failwith "Ran out of aligns" + | x :: _ -> + if x > 0 then emitString " " x; + x); + wantIndent := false + in + (* A continuation passing style loop *) + let rec loopCont (abscol: int) (d: doc) (cont: int -> unit) : unit + (* the new column *) = + match d with + Nil -> cont abscol + | Concat (d1, d2) -> + loopCont abscol d1 (fun abscol' -> loopCont abscol' d2 cont) + + | Text s when shallowAlign () -> + let sl = String.length s in + indentIfNeeded (); + emitString s 1; + cont (abscol + sl) + + | CText (d, s) -> + loopCont abscol d + (fun abscol' -> + if shallowAlign () then + let sl = String.length s in + indentIfNeeded (); + emitString s 1; + cont (abscol' + sl) + else + cont abscol') + + | Align -> + aligns := abscol :: !aligns; + if enterAlign () then begin + indentIfNeeded (); + emitString "..." 1; + cont (abscol + 3) + end else + cont abscol + + | Unalign -> begin + match !aligns with + [] -> failwith "Unmatched unalign" + | _ :: rest -> + exitAlign (); + aligns := rest; cont abscol + end + | Line when shallowAlign () -> cont (newline ()) + | LeftFlush when shallowAlign () -> wantIndent := false; cont (0) + | Break when shallowAlign () -> begin + match !breaks with + [] -> failwith "Break without a takenref" + | istaken :: rest -> + breaks := rest; (* Consume the break *) + if !istaken then cont (newline ()) + else begin + indentIfNeeded (); + emitString " " 1; + cont (abscol + 1) + end + end + + | Mark -> + activeMarkups := abscol :: !activeMarkups; + cont abscol + + | Unmark -> begin + match !activeMarkups with + old :: rest -> activeMarkups := rest; + cont old + | [] -> failwith "Unmark without a mark" + end + + | _ -> (* Align is too deep *) + cont abscol + in + + loopCont 0 d (fun x -> ()) + + +(* Print a document on a channel *) +let fprint (chn: out_channel) ~(width: int) doc = + (* Save some parameters, to allow for nested calls of these routines. *) + maxCol := width; + let old_breaks = !breaks in + breaks := []; + let old_alignDepth = !alignDepth in + alignDepth := 0; + let old_activeMarkups = !activeMarkups in + activeMarkups := []; + ignore (scan 0 doc); + breaks := List.rev !breaks; + ignore (emitDoc + (fun s nrcopies -> + for i = 1 to nrcopies do + output_string chn s + done) doc); + activeMarkups := old_activeMarkups; + alignDepth := old_alignDepth; + breaks := old_breaks (* We must do this especially if we don't do emit + * (which consumes breaks) because otherwise we waste + * memory *) + +(* Print the document to a string *) +let sprint ~(width : int) doc : string = + maxCol := width; + let old_breaks = !breaks in + breaks := []; + let old_activeMarkups = !activeMarkups in + activeMarkups := []; + let old_alignDepth = !alignDepth in + alignDepth := 0; + ignore (scan 0 doc); + breaks := List.rev !breaks; + let buf = Buffer.create 1024 in + let rec add_n_strings str num = + if num <= 0 then () + else begin Buffer.add_string buf str; add_n_strings str (num - 1) end + in + emitDoc add_n_strings doc; + breaks := old_breaks; + activeMarkups := old_activeMarkups; + alignDepth := old_alignDepth; + Buffer.contents buf + + + (* The rest is based on printf.ml *) +external format_int: string -> int -> string = "caml_format_int" +external format_float: string -> float -> string = "caml_format_float" + + + +let gprintf (finish : doc -> 'b) + (format : ('a, unit, doc, 'b) format4) : 'a = + let format = (Obj.magic format : string) in + + (* Record the starting align depth *) + let startAlignDepth = !alignDepth in + (* Special concatenation functions *) + let dconcat (acc: doc) (another: doc) = + if !alignDepth > !printDepth then acc else acc ++ another in + let dctext1 (acc: doc) (str: string) = + if !alignDepth > !printDepth then acc else + CText(acc, str) + in + (* Special finish function *) + let dfinish (dc: doc) : 'b = + if !alignDepth <> startAlignDepth then + prerr_string ("Unmatched align/unalign in " ^ format ^ "\n"); + finish dc + in + let flen = String.length format in + (* Reading a format character *) + let fget = String.unsafe_get format in + (* Output a literal sequence of + * characters, starting at i. The + * character at i does not need to be + * checked. *) + let rec literal acc i = + let rec skipChars j = + if j >= flen || + (match fget j with + '%' -> true + | '@' -> true + | '\n' -> true + | _ -> false) then + collect (dctext1 acc (String.sub format i (j-i))) j + else + skipChars (succ j) + in + skipChars (succ i) + (* the main collection function *) + and collect (acc: doc) (i: int) = + if i >= flen then begin + Obj.magic (dfinish acc) + end else begin + let c = fget i in + if c = '%' then begin + let j = skip_args (succ i) in + match fget j with + '%' -> literal acc j + | 's' -> + Obj.magic(fun s -> + let str = + if j <= i+1 then + s + else + let sl = String.length s in + let p = + try + int_of_string (String.sub format (i+1) (j-i-1)) + with _ -> + invalid_arg "fprintf: bad %s format" in + if p > 0 && sl < p then + (String.make (p - sl) ' ') ^ s + else if p < 0 && sl < -p then + s ^ (String.make (-p - sl) ' ') + else + s + in + collect (breakString acc str) (succ j)) + | 'c' -> + Obj.magic(fun c -> + collect (dctext1 acc (String.make 1 c)) (succ j)) + | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' -> + Obj.magic(fun n -> + collect (dctext1 acc + (format_int (String.sub format i + (j-i+1)) n)) + (succ j)) + (* L, l, and n are the Int64, Int32, and Nativeint modifiers to the integer + formats d,i,o,x,X,u. For example, %Lo means print an Int64 in octal.*) + | 'L' -> + if j != i + 1 then (*Int64.format handles simple formats like %d. + * Any special flags eaten by skip_args will confuse it. *) + invalid_arg ("dprintf: unimplemented format " + ^ (String.sub format i (j-i+1))); + let j' = succ j in (* eat the d,i,x etc. *) + let format_spec = "% " in + String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *) + Obj.magic(fun n -> + collect (dctext1 acc + (Int64.format format_spec n)) + (succ j')) + | 'l' -> + if j != i + 1 then invalid_arg ("dprintf: unimplemented format " + ^ (String.sub format i (j-i+1))); + let j' = succ j in (* eat the d,i,x etc. *) + let format_spec = "% " in + String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *) + Obj.magic(fun n -> + collect (dctext1 acc + (Int32.format format_spec n)) + (succ j')) + | 'n' -> + if j != i + 1 then invalid_arg ("dprintf: unimplemented format " + ^ (String.sub format i (j-i+1))); + let j' = succ j in (* eat the d,i,x etc. *) + let format_spec = "% " in + String.set format_spec 1 (fget j'); (* format_spec = "%x", etc. *) + Obj.magic(fun n -> + collect (dctext1 acc + (Nativeint.format format_spec n)) + (succ j')) + | 'f' | 'e' | 'E' | 'g' | 'G' -> + Obj.magic(fun f -> + collect (dctext1 acc + (format_float (String.sub format i (j-i+1)) f)) + (succ j)) + | 'b' | 'B' -> + Obj.magic(fun b -> + collect (dctext1 acc (string_of_bool b)) (succ j)) + | 'a' -> + Obj.magic(fun pprinter arg -> + collect (dconcat acc (pprinter () arg)) (succ j)) + | 't' -> + Obj.magic(fun pprinter -> + collect (dconcat acc (pprinter ())) (succ j)) + | c -> + invalid_arg ("dprintf: unknown format %s" ^ String.make 1 c) + + end else if c = '@' then begin + if i + 1 < flen then begin + match fget (succ i) with + + (* Now the special format characters *) + '[' -> (* align *) + let newacc = + if !alignDepth > !printDepth then + acc + else if !alignDepth = !printDepth then + CText(acc, "...") + else + acc ++ align + in + incr alignDepth; + collect newacc (i + 2) + + | ']' -> (* unalign *) + decr alignDepth; + let newacc = + if !alignDepth >= !printDepth then + acc + else + acc ++ unalign + in + collect newacc (i + 2) + | '!' -> (* hard-line break *) + collect (dconcat acc line) (i + 2) + | '?' -> (* soft line break *) + collect (dconcat acc (break)) (i + 2) + | '<' -> + collect (dconcat acc mark) (i +1) + | '>' -> + collect (dconcat acc unmark) (i +1) + | '^' -> (* left-flushed *) + collect (dconcat acc (leftflush)) (i + 2) + | '@' -> + collect (dctext1 acc "@") (i + 2) + | c -> + invalid_arg ("dprintf: unknown format @" ^ String.make 1 c) + end else + invalid_arg "dprintf: incomplete format @" + end else if c = '\n' then begin + collect (dconcat acc line) (i + 1) + end else + literal acc i + end + + and skip_args j = + match String.unsafe_get format j with + '0' .. '9' | ' ' | '.' | '-' -> skip_args (succ j) + | c -> j + + in + collect Nil 0 + +let withPrintDepth dp thunk = + let opd = !printDepth in + printDepth := dp; + thunk (); + printDepth := opd + + + +let flushOften = ref false + +let dprintf format = gprintf (fun x -> x) format +let fprintf chn format = + let f d = fprint chn 80 d; d in + (* weimeric hack begins -- flush output to streams *) + let res = gprintf f format in + (* save the value we would have returned, flush the channel and then + * return it -- this allows us to see debug input near infinite loops + * *) + if !flushOften then flush chn; + res + (* weimeric hack ends *) + +let printf format = fprintf stdout format +let eprintf format = fprintf stderr format + + + +(******************************************************************************) +let getAlgoName = function + George -> "George" + | Aman -> "Aman" + | Gap -> "Gap" + +let getAboutString () : string = + "(Pretty: ALGO=" ^ (getAlgoName algo) ^ ")" + + +(************************************************) +let auto_printer (typ: string) = + failwith ("Pretty.auto_printer \"" ^ typ ^ "\" only works with you use -pp \"camlp4o pa_prtype.cmo\" when you compile") diff --git a/cil/ocamlutil/pretty.mli b/cil/ocamlutil/pretty.mli new file mode 100644 index 0000000..5422432 --- /dev/null +++ b/cil/ocamlutil/pretty.mli @@ -0,0 +1,316 @@ +(* + * + * Copyright (c) 2001 by + * George C. Necula necula@cs.berkeley.edu + * Scott McPeak smcpeak@cs.berkeley.edu + * Wes Weimer weimer@cs.berkeley.edu + * + * All rights reserved. Permission to use, copy, modify and distribute + * this software for research purposes only is hereby granted, + * provided that the following conditions are met: + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * 3. The name of the authors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * DISCLAIMER: + * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(** Utility functions for pretty-printing. The major features provided by + this module are +- An [fprintf]-style interface with support for user-defined printers +- The printout is fit to a width by selecting some of the optional newlines +- Constructs for alignment and indentation +- Print ellipsis starting at a certain nesting depth +- Constructs for printing lists and arrays + + Pretty-printing occurs in two stages: +- Construct a {!Pretty.doc} object that encodes all of the elements to be + printed + along with alignment specifiers and optional and mandatory newlines +- Format the {!Pretty.doc} to a certain width and emit it as a string, to an + output stream or pass it to a user-defined function + + The formatting algorithm is not optimal but it does a pretty good job while + still operating in linear time. The original version was based on a pretty + printer by Philip Wadler which turned out to not scale to large jobs. +*) + +(** API *) + +(** The type of unformated documents. Elements of this type can be + * constructed in two ways. Either with a number of constructor shown below, + * or using the {!Pretty.dprintf} function with a [printf]-like interface. + * The {!Pretty.dprintf} method is slightly slower so we do not use it for + * large jobs such as the output routines for a compiler. But we use it for + * small jobs such as logging and error messages. *) +type doc + + + +(** Constructors for the doc type. *) + + + + +(** Constructs an empty document *) +val nil : doc + + +(** Concatenates two documents. This is an infix operator that associates to + the left. *) +val (++) : doc -> doc -> doc +val concat : doc -> doc -> doc + +(** A document that prints the given string *) +val text : string -> doc + + +(** A document that prints an integer in decimal form *) +val num : int -> doc + + +(** A document that prints a real number *) +val real : float -> doc + +(** A document that prints a character. This is just like {!Pretty.text} + with a one-character string. *) +val chr : char -> doc + + +(** A document that consists of a mandatory newline. This is just like [(text + "\n")]. The new line will be indented to the current indentation level, + unless you use {!Pretty.leftflush} right after this. *) +val line : doc + +(** Use after a {!Pretty.line} to prevent the indentation. Whatever follows + * next will be flushed left. Indentation resumes on the next line. *) +val leftflush : doc + + +(** A document that consists of either a space or a line break. Also called + an optional line break. Such a break will be + taken only if necessary to fit the document in a given width. If the break + is not taken a space is printed instead. *) +val break: doc + +(** Mark the current column as the current indentation level. Does not print + anything. All taken line breaks will align to this column. The previous + alignment level is saved on a stack. *) +val align: doc + +(** Reverts to the last saved indentation level. *) +val unalign: doc + + +(** Mark the beginning of a markup section. The width of a markup section is + * considered 0 for the purpose of computing identation *) +val mark: doc + +(** The end of a markup section *) +val unmark: doc + +(************* Now some syntactic sugar *****************) +(** Syntactic sugar *) + +(** Indents the document. Same as [((text " ") ++ align ++ doc ++ unalign)], + with the specified number of spaces. *) +val indent: int -> doc -> doc + +(** Prints a document as markup. The marked document cannot contain line + * breaks or alignment constructs. *) +val markup: doc -> doc + +(** Formats a sequence. [sep] is a separator, [doit] is a function that + * converts an element to a document. *) +val seq: sep:doc -> doit:('a ->doc) -> elements:'a list -> doc + + +(** An alternative function for printing a list. The [unit] argument is there + * to make this function more easily usable with the {!Pretty.dprintf} + * interface. The first argument is a separator, by default a comma. *) +val docList: ?sep:doc -> ('a -> doc) -> unit -> 'a list -> doc + +(** sm: Yet another list printer. This one accepts the same kind of + * printing function that {!Pretty.dprintf} does, and itself works + * in the dprintf context. Also accepts + * a string as the separator since that's by far the most common. *) +val d_list: string -> (unit -> 'a -> doc) -> unit -> 'a list -> doc + +(** Formats an array. A separator and a function that prints an array + element. The default separator is a comma. *) +val docArray: ?sep:doc -> (int -> 'a -> doc) -> unit -> 'a array -> doc + +(** Prints an ['a option] with [None] or [Some] *) +val docOpt: ('a -> doc) -> unit -> 'a option -> doc + + +(** Print an int32 *) +val d_int32: int32 -> doc +val f_int32: unit -> int32 -> doc + +val d_int64: int64 -> doc +val f_int64: unit -> int64 -> doc + +(** Format maps. *) +module MakeMapPrinter : + functor (Map: sig + type key + type 'a t + val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b + end) -> +sig + (** Format a map, analogous to docList. *) + val docMap: ?sep:doc -> (Map.key -> 'a -> doc) -> unit -> 'a Map.t -> doc + + (** Format a map, analogous to d_list. *) + val d_map: ?dmaplet:(doc -> doc -> doc) + -> string + -> (unit -> Map.key -> doc) + -> (unit -> 'a -> doc) + -> unit + -> 'a Map.t + -> doc + end + +(** Format sets. *) +module MakeSetPrinter : + functor (Set: sig + type elt + type t + val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a + end) -> +sig + (** Format a set, analogous to docList. *) + val docSet: ?sep:doc -> (Set.elt -> doc) -> unit -> Set.t -> doc + + (** Format a set, analogous to d_list. *) + val d_set: string + -> (unit -> Set.elt -> doc) + -> unit + -> Set.t + -> doc +end + +(** A function that is useful with the [printf]-like interface *) +val insert: unit -> doc -> doc + +val dprintf: ('a, unit, doc, doc) format4 -> 'a +(** This function provides an alternative method for constructing + [doc] objects. The first argument for this function is a format string + argument (of type [('a, unit, doc) format]; if you insist on + understanding what that means see the module [Printf]). The format string + is like that for the [printf] function in C, except that it understands a + few more formatting controls, all starting with the @ character. + + See the gprintf function if you want to pipe the result of dprintf into + some other functions. + + The following special formatting characters are understood (these do not + correspond to arguments of the function): +- @\[ Inserts an {!Pretty.align}. Every format string must have matching + {!Pretty.align} and {!Pretty.unalign}. +- @\] Inserts an {!Pretty.unalign}. +- @! Inserts a {!Pretty.line}. Just like "\n" +- @? Inserts a {!Pretty.break}. +- @< Inserts a {!Pretty.mark}. +- @> Inserts a {!Pretty.unmark}. +- @^ Inserts a {!Pretty.leftflush} + Should be used immediately after @! or "\n". +- @@ : inserts a @ character + + In addition to the usual [printf] % formatting characters the following two + new characters are supported: +- %t Corresponds to an argument of type [unit -> doc]. This argument is + invoked to produce a document +- %a Corresponds to {b two} arguments. The first of type [unit -> 'a -> doc] + and the second of type ['a]. (The extra [unit] is do to the + peculiarities of the built-in support for format strings in Ocaml. It + turns out that it is not a major problem.) Here is an example of how + you use this: + +{v dprintf "Name=%s, SSN=%7d, Children=\@\[%a\@\]\n" + pers.name pers.ssn (docList (chr ',' ++ break) text) + pers.children v} + + The result of [dprintf] is a {!Pretty.doc}. You can format the document and + emit it using the functions {!Pretty.fprint} and {!Pretty.sprint}. + +*) + +(** Like {!Pretty.dprintf} but more general. It also takes a function that is + * invoked on the constructed document but before any formatting is done. The + * type of the format argument means that 'a is the type of the parameters of + * this function, unit is the type of the first argument to %a and %t + * formats, doc is the type of the intermediate result, and 'b is the type of + * the result of gprintf. *) +val gprintf: (doc -> 'b) -> ('a, unit, doc, 'b) format4 -> 'a + +(** Format the document to the given width and emit it to the given channel *) +val fprint: out_channel -> width:int -> doc -> unit + +(** Format the document to the given width and emit it as a string *) +val sprint: width:int -> doc -> string + +(** Like {!Pretty.dprintf} followed by {!Pretty.fprint} *) +val fprintf: out_channel -> ('a, unit, doc) format -> 'a + +(** Like {!Pretty.fprintf} applied to [stdout] *) +val printf: ('a, unit, doc) format -> 'a + +(** Like {!Pretty.fprintf} applied to [stderr] *) +val eprintf: ('a, unit, doc) format -> 'a + + +(* sm: arg! why can't I write this function?! *) +(* * Like {!Pretty.dprintf} but yielding a string with no newlines *) +(*val sprintf: (doc, unit, doc) format -> string*) + +(* sm: different tack.. *) +(* doesn't work either. well f it anyway *) +(*val failwithf: ('a, unit, doc) format -> 'a*) + + +(** Invokes a thunk, with printDepth temporarily set to the specified value *) +val withPrintDepth : int -> (unit -> unit) -> unit + +(** The following variables can be used to control the operation of the printer *) + +(** Specifies the nesting depth of the [align]/[unalign] pairs at which + everything is replaced with ellipsis *) +val printDepth : int ref + +val printIndent : bool ref (** If false then does not indent *) + + +(** If set to [true] then optional breaks are taken only when the document + has exceeded the given width. This means that the printout will looked + more ragged but it will be faster *) +val fastMode : bool ref + +val flushOften : bool ref (** If true the it flushes after every print *) + + +(** Keep a running count of the taken newlines. You can read and write this + * from the client code if you want *) +val countNewLines : int ref + + +(** A function that when used at top-level in a module will direct + * the pa_prtype module generate automatically the printing functions for a + * type *) +val auto_printer: string -> 'b diff --git a/cil/ocamlutil/stats.ml b/cil/ocamlutil/stats.ml new file mode 100644 index 0000000..8bbb7d0 --- /dev/null +++ b/cil/ocamlutil/stats.ml @@ -0,0 +1,146 @@ +(* The following functions are implemented in perfcount.c *) + +(* Returns true is we have the performance counters *) +external has_performance_counters: unit -> bool = "has_performance_counters" + +(* Returns number of seconds since the first read *) +external read_pentium_perfcount : unit -> float = "read_pentium_perfcount" + +(* Returns current cycle counter, divided by 1^20, and truncated to 30 bits *) +external sample_pentium_perfcount_20 : unit -> int = "sample_pentium_perfcount_20" + +(* Returns current cycle counter, divided by 1^10, and truncated to 30 bits *) +external sample_pentium_perfcount_10 : unit -> int = "sample_pentium_perfcount_10" + + +(* Whether to use the performance counters (on Pentium only) *) + +(* The performance counters are disabled by default. *) +let do_use_performance_counters = ref false + + (* A hierarchy of timings *) + +type t = { name : string; + mutable time : float; (* In seconds *) + mutable sub : t list} + + (* Create the top level *) +let top = { name = "TOTAL"; + time = 0.0; + sub = []; } + + (* The stack of current path through + * the hierarchy. The first is the + * leaf. *) +let current : t list ref = ref [top] + +exception NoPerfCount +let reset (perfcount: bool) = + top.sub <- []; + if perfcount then begin + if not (has_performance_counters ()) then begin + raise NoPerfCount + end + end; + do_use_performance_counters := perfcount + + + +let print chn msg = + (* Total up *) + top.time <- List.fold_left (fun sum f -> sum +. f.time) 0.0 top.sub; + let rec prTree ind node = + if !do_use_performance_counters then + (Printf.fprintf chn "%s%-20s %8.5f s\n" + (String.make ind ' ') node.name node.time) + else + (Printf.fprintf chn "%s%-20s %6.3f s\n" + (String.make ind ' ') node.name node.time); + + List.iter (prTree (ind + 2)) (List.rev node.sub) + in + Printf.fprintf chn "%s" msg; + List.iter (prTree 0) [ top ]; + Printf.fprintf chn "Timing used %s\n" + (if !do_use_performance_counters then "Pentium performance counters" + else "Unix.time"); + let gc = Gc.quick_stat () in + let printM (w: float) : string = + Printf.sprintf "%.2fMb" (w *. 4.0 /. 1000000.0) + in + Printf.fprintf chn + "Memory statistics: total=%s, max=%s, minor=%s, major=%s, promoted=%s\n minor collections=%d major collections=%d compactions=%d\n" + (printM (gc.Gc.minor_words +. gc.Gc.major_words + -. gc.Gc.promoted_words)) + (printM (float_of_int gc.Gc.top_heap_words)) + (printM gc.Gc.minor_words) + (printM gc.Gc.major_words) + (printM gc.Gc.promoted_words) + gc.Gc.minor_collections + gc.Gc.major_collections + gc.Gc.compactions; + + () + + + +(* Get the current time, in seconds *) +let get_current_time () : float = + if !do_use_performance_counters then + read_pentium_perfcount () + else + (Unix.times ()).Unix.tms_utime + +let repeattime limit str f arg = + (* Find the right stat *) + let stat : t = + let curr = match !current with h :: _ -> h | _ -> assert false in + let rec loop = function + h :: _ when h.name = str -> h + | _ :: rest -> loop rest + | [] -> + let nw = {name = str; time = 0.0; sub = []} in + curr.sub <- nw :: curr.sub; + nw + in + loop curr.sub + in + let oldcurrent = !current in + current := stat :: oldcurrent; + let start = get_current_time () in + let rec repeatf count = + let res = f arg in + let diff = get_current_time () -. start in + if diff < limit then + repeatf (count + 1) + else begin + stat.time <- stat.time +. (diff /. float(count)); + current := oldcurrent; (* Pop the current stat *) + res (* Return the function result *) + end + in + repeatf 1 + + +let time str f arg = repeattime 0.0 str f arg + + +let lastTime = ref 0.0 +let timethis (f: 'a -> 'b) (arg: 'a) : 'b = + let start = get_current_time () in + let res = f arg in + lastTime := get_current_time () -. start; + res + + + + + + + + + + + + + diff --git a/cil/ocamlutil/stats.mli b/cil/ocamlutil/stats.mli new file mode 100644 index 0000000..9ed98e5 --- /dev/null +++ b/cil/ocamlutil/stats.mli @@ -0,0 +1,72 @@ +(* + * + * Copyright (c) 2001 by + * George C. Necula necula@cs.berkeley.edu + * Scott McPeak smcpeak@cs.berkeley.edu + * Wes Weimer weimer@cs.berkeley.edu + * + * All rights reserved. Permission to use, copy, modify and distribute + * this software for research purposes only is hereby granted, + * provided that the following conditions are met: + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * 3. The name of the authors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * DISCLAIMER: + * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(** Utilities for maintaining timing statistics *) + +(** Resets all the timings. Invoke with "true" if you want to switch to using + * the hardware performance counters from now on. You get an exception if + * there are not performance counters available *) +val reset: bool -> unit +exception NoPerfCount + +(** Check if we have performance counters *) +val has_performance_counters: unit -> bool + +(** Sample the current cycle count, in megacycles. *) +val sample_pentium_perfcount_20: unit -> int + +(** Sample the current cycle count, in kilocycles. *) +val sample_pentium_perfcount_10: unit -> int + +(** Time a function and associate the time with the given string. If some + timing information is already associated with that string, then accumulate + the times. If this function is invoked within another timed function then + you can have a hierarchy of timings *) +val time : string -> ('a -> 'b) -> 'a -> 'b + +(** repeattime is like time but runs the function several times until the total + running time is greater or equal to the first argument. The total time is + then divided by the number of times the function was run. *) +val repeattime : float -> string -> ('a -> 'b) -> 'a -> 'b + +(** Print the current stats preceeded by a message *) +val print : out_channel -> string -> unit + + + +(** Time a function and set lastTime to the time it took *) +val lastTime: float ref +val timethis: ('a -> 'b) -> 'a -> 'b + + + + diff --git a/cil/ocamlutil/trace.ml b/cil/ocamlutil/trace.ml new file mode 100644 index 0000000..b429286 --- /dev/null +++ b/cil/ocamlutil/trace.ml @@ -0,0 +1,169 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* Trace module implementation + * see trace.mli + *) + +open Pretty;; + + +(* --------- traceSubsystems --------- *) +(* this is the list of tags (usually subsystem names) for which + * trace output will appear *) +let traceSubsystems : string list ref = ref [];; + + +let traceAddSys (subsys : string) : unit = + (* (ignore (printf "traceAddSys %s\n" subsys)); *) + traceSubsystems := subsys :: !traceSubsystems +;; + + +let traceActive (subsys : string) : bool = + (* (List.mem elt list) returns true if something in list equals ('=') elt *) + (List.mem subsys !traceSubsystems) +;; + + +let rec parseString (str : string) (delim : char) : string list = +begin + if (not (String.contains str delim)) then + if ((String.length str) = 0) then + [] + else + [str] + + else + let d = ((String.index str delim) + 1) in + if (d = 1) then + (* leading delims are eaten *) + (parseString (String.sub str d ((String.length str) - d)) delim) + else + (String.sub str 0 (d-1)) :: + (parseString (String.sub str d ((String.length str) - d)) delim) +end;; + +let traceAddMulti (systems : string) : unit = +begin + let syslist = (parseString systems ',') in + (List.iter traceAddSys syslist) +end;; + + + +(* --------- traceIndent --------- *) +let traceIndentLevel : int ref = ref 0;; + + +let traceIndent (sys : string) : unit = + if (traceActive sys) then + traceIndentLevel := !traceIndentLevel + 2 +;; + +let traceOutdent (sys : string) : unit = + if ((traceActive sys) && + (!traceIndentLevel >= 2)) then + traceIndentLevel := !traceIndentLevel - 2 +;; + + +(* --------- trace --------- *) +(* return a tag to prepend to a trace output + * e.g. " %%% mysys: " + *) +let traceTag (sys : string) : Pretty.doc = + (* return string of 'i' spaces *) + let rec ind (i : int) : string = + if (i <= 0) then + "" + else + " " ^ (ind (i-1)) + + in + (text ((ind !traceIndentLevel) ^ "%%% " ^ sys ^ ": ")) +;; + + +(* this is the trace function; its first argument is a string + * tag, and subsequent arguments are like printf formatting + * strings ("%a" and whatnot) *) +let trace + (subsys : string) (* subsystem identifier for enabling tracing *) + (d : Pretty.doc) (* something made by 'dprintf' *) + : unit = (* no return value *) + (* (ignore (printf "trace %s\n" subsys)); *) + + (* see if the subsystem's tracing is turned on *) + if (traceActive subsys) then + begin + (fprint stderr 80 (* print it *) + ((traceTag subsys) ++ d)); (* with prepended subsys tag *) + (* mb: flush after every message; useful if the program hangs in an + infinite loop... *) + (flush stderr) + end + else + () (* eat it *) +;; + + +let tracei (sys : string) (d : Pretty.doc) : unit = + (* trace before indent *) + (trace sys d); + (traceIndent sys) +;; + +let traceu (sys : string) (d : Pretty.doc) : unit = + (* trace after outdent *) + (* no -- I changed my mind -- I want trace *then* outdent *) + (trace sys d); + (traceOutdent sys) +;; + + + + +(* -------------------------- trash --------------------- *) +(* TRASH START + +(* sm: more experimenting *) +(trace "no" (dprintf "no %d\n" 5)); +(trace "yes" (dprintf "yes %d\n" 6)); +(trace "maybe" (dprintf "maybe %d\n" 7)); + +TRASH END *) diff --git a/cil/ocamlutil/trace.mli b/cil/ocamlutil/trace.mli new file mode 100644 index 0000000..46ca652 --- /dev/null +++ b/cil/ocamlutil/trace.mli @@ -0,0 +1,106 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* Trace module + * Scott McPeak, 5/4/00 + * + * The idea is to pepper the source with debugging printfs, + * and be able to select which ones to actually display at + * runtime. + * + * It is built on top of the Pretty module for printing data + * structures. + * + * To a first approximation, this is needed to compensate for + * the lack of a debugger that does what I want... + *) + + +(* this is the list of tags (usually subsystem names) for which + * trace output will appear *) +val traceSubsystems : string list ref + +(* interface to add a new subsystem to trace (slightly more + * convenient than direclty changing 'tracingSubsystems') *) +val traceAddSys : string -> unit + +(* query whether a particular subsystem is being traced *) +val traceActive : string -> bool + +(* add several systems, separated by commas *) +val traceAddMulti : string -> unit + + +(* current indentation level for tracing *) +val traceIndentLevel : int ref + +(* bump up or down the indentation level, if the given subsys + * is being traced *) +val traceIndent : string -> unit +val traceOutdent : string -> unit + + +(* this is the trace function; its first argument is a string + * tag, and second argument is a 'doc' (which is what 'dprintf' + * returns). + * + * so a sample usage might be + * (trace "mysubsys" (dprintf "something neat happened %d times\n" counter)) + *) +val trace : string -> Pretty.doc -> unit + + +(* special flavors that indent/outdent as well. the indent version + * indents *after* printing, while the outdent version outdents + * *before* printing. thus, a sequence like + * + * (tracei "foo" (dprintf "beginning razzle-dazzle\n")) + * ..razzle.. + * ..dazzle.. + * (traceu "foo" (dprintf "done with razzle-dazzle\n")) + * + * will do the right thing + * + * update -- I changed my mind! I decided I prefer it like this + * %%% sys: (myfunc args) + * %%% ...inner stuff... + * %%% sys: myfunc returning 56 + * + * so now they both print before in/outdenting + *) +val tracei : string -> Pretty.doc -> unit +val traceu : string -> Pretty.doc -> unit diff --git a/cil/ocamlutil/util.ml b/cil/ocamlutil/util.ml new file mode 100755 index 0000000..e6c2c67 --- /dev/null +++ b/cil/ocamlutil/util.ml @@ -0,0 +1,815 @@ +(** Utility functions for Coolaid *) +module E = Errormsg +module H = Hashtbl +module IH = Inthash + +open Pretty + +exception GotSignal of int + +let withTimeout (secs: float) (* Seconds for timeout *) + (handler: int -> 'b) (* What to do if we have a timeout. The + * argument passed is the signal number + * received. *) + (f: 'a -> 'b) (* The function to run *) + (arg: 'a) (* And its argument *) + : 'b = + let oldHandler = + Sys.signal Sys.sigalrm + (Sys.Signal_handle + (fun i -> + ignore (E.log "Got signal %d\n" i); + raise (GotSignal i))) + in + let reset_sigalrm () = + ignore (Unix.setitimer Unix.ITIMER_REAL { Unix.it_value = 0.0; + Unix.it_interval = 0.0;}); + Sys.set_signal Sys.sigalrm oldHandler; + in + ignore (Unix.setitimer Unix.ITIMER_REAL + { Unix.it_value = secs; + Unix.it_interval = 0.0;}); + (* ignore (Unix.alarm 2); *) + try + let res = f arg in + reset_sigalrm (); + res + with exc -> begin + reset_sigalrm (); + ignore (E.log "Got an exception\n"); + match exc with + GotSignal i -> + handler i + | _ -> raise exc + end + +(** Print a hash table *) +let docHash ?(sep=chr ',') (one: 'a -> 'b -> doc) () (h: ('a, 'b) H.t) = + (H.fold + (fun key data acc -> + if acc == align then acc ++ one key data + else acc ++ sep ++ one key data) + h + align) ++ unalign + + + +let hash_to_list (h: ('a, 'b) H.t) : ('a * 'b) list = + H.fold + (fun key data acc -> (key, data) :: acc) + h + [] + +let keys (h: ('a, 'b) H.t) : 'a list = + H.fold + (fun key data acc -> key :: acc) + h + [] + +let hash_copy_into (hfrom: ('a, 'b) H.t) (hto: ('a, 'b) H.t) : unit = + H.clear hto; + H.iter (H.add hto) hfrom + +let anticompare a b = compare b a +;; + + +let rec list_drop (n : int) (xs : 'a list) : 'a list = + if n < 0 then invalid_arg "Util.list_drop"; + if n = 0 then + xs + else begin + match xs with + | [] -> invalid_arg "Util.list_drop" + | y::ys -> list_drop (n-1) ys + end + +let list_droptail (n : int) (xs : 'a list) : 'a list = + if n < 0 then invalid_arg "Util.list_droptail"; + let (ndrop,r) = + List.fold_right + (fun x (ndrop,acc) -> + if ndrop = 0 then (ndrop, x :: acc) + else (ndrop-1, acc)) + xs + (n,[]) + in + if ndrop > 0 then invalid_arg "Util.listdroptail" + else r + +let rec list_span (p : 'a -> bool) (xs : 'a list) : 'a list * 'a list = + begin match xs with + | [] -> ([],[]) + | x::xs' -> + if p x then + let (ys,zs) = list_span p xs' in (x::ys,zs) + else ([],xs) + end +;; + +let rec list_rev_append revxs ys = + begin match revxs with + | [] -> ys + | x::xs -> list_rev_append xs (x::ys) + end +;; +let list_insert_by (cmp : 'a -> 'a -> int) + (x : 'a) (xs : 'a list) : 'a list = + let rec helper revhs ts = + begin match ts with + | [] -> List.rev (x::revhs) + | t::ts' -> + if cmp x t >= 0 then helper (t::revhs) ts' + else list_rev_append (x::revhs) ts + end + in + helper [] xs +;; + +let list_head_default (d : 'a) (xs : 'a list) : 'a = + begin match xs with + | [] -> d + | x::_ -> x + end +;; + +let rec list_iter3 f xs ys zs = + begin match xs, ys, zs with + | [], [], [] -> () + | x::xs, y::ys, z::zs -> f x y z; list_iter3 f xs ys zs + | _ -> invalid_arg "Util.list_iter3" + end +;; + +let rec get_some_option_list (xs : 'a option list) : 'a list = + begin match xs with + | [] -> [] + | None::xs -> get_some_option_list xs + | Some x::xs -> x :: get_some_option_list xs + end +;; + +(* tail-recursive append: reverses xs twice *) +let list_append (xs: 'a list) (ys: 'a list): 'a list = + match xs with (* optimize some common cases *) + [] -> ys + | [x] -> x::ys + | _ -> list_rev_append (List.rev xs) ys + +let list_iteri (f: int -> 'a -> unit) (l: 'a list) : unit = + let rec loop (i: int) (l: 'a list) : unit = + match l with + [] -> () + | h :: t -> f i h; loop (i + 1) t + in + loop 0 l + +let list_mapi (f: int -> 'a -> 'b) (l: 'a list) : 'b list = + let rec loop (i: int) (l: 'a list) : 'b list = + match l with + [] -> [] + | h :: t -> + let headres = f i h in + headres :: loop (i + 1) t + in + loop 0 l + +let list_fold_lefti (f: 'acc -> int -> 'a -> 'acc) (start: 'acc) + (l: 'a list) : 'acc = + let rec loop (i, acc) l = + match l with + [] -> acc + | h :: t -> loop (i + 1, f acc i h) t + in + loop (0, start) l + + +let list_init (len : int) (init_fun : int -> 'a) : 'a list = + let rec loop n acc = + if n < 0 then acc + else loop (n-1) ((init_fun n)::acc) + in + loop (len - 1) [] +;; + + +let rec list_find_first (l: 'a list) (f: 'a -> 'b option) : 'b option = + match l with + [] -> None + | h :: t -> begin + match f h with + None -> list_find_first t f + | r -> r + end + +(** Generates the range of integers starting with a and ending with b *) +let int_range_list (a: int) (b: int) = + list_init (b - a + 1) (fun i -> a + i) + + +(** Some handling of registers *) +type 'a growArrayFill = + Elem of 'a + | Susp of (int -> 'a) + +type 'a growArray = { + gaFill: 'a growArrayFill; + (** Stuff to use to fill in the array as it grows *) + + mutable gaMaxInitIndex: int; + (** Maximum index that was written to. -1 if no writes have + * been made. *) + + mutable gaData: 'a array; + } + +let growTheArray (ga: 'a growArray) (len: int) + (toidx: int) (why: string) : unit = + if toidx >= len then begin + (* Grow the array by 50% *) + let newlen = toidx + 1 + len / 2 in +(* + ignore (E.log "growing an array to idx=%d (%s)\n" toidx why); +*) + let data' = begin match ga.gaFill with + Elem x -> + + let data'' = Array.create newlen x in + Array.blit ga.gaData 0 data'' 0 len; + data'' + | Susp f -> Array.init newlen + (fun i -> if i < len then ga.gaData.(i) else f i) + end + in + ga.gaData <- data' + end + +let getReg (ga: 'a growArray) (r: int) : 'a = + let len = Array.length ga.gaData in + if r >= len then + growTheArray ga len r "get"; + + ga.gaData.(r) + +let setReg (ga: 'a growArray) (r: int) (what: 'a) : unit = + let len = Array.length ga.gaData in + if r >= len then + growTheArray ga len r "set"; + if r > ga.gaMaxInitIndex then ga.gaMaxInitIndex <- r; + ga.gaData.(r) <- what + +let newGrowArray (initsz: int) (fill: 'a growArrayFill) : 'a growArray = + { gaFill = fill; + gaMaxInitIndex = -1; + gaData = begin match fill with + Elem x -> Array.create initsz x + | Susp f -> Array.init initsz f + end; } + +let copyGrowArray (ga: 'a growArray) : 'a growArray = + { ga with gaData = Array.copy ga.gaData } + +let deepCopyGrowArray (ga: 'a growArray) (copy: 'a -> 'a): 'a growArray = + { ga with gaData = Array.map copy ga.gaData } + + + +(** Iterate over the initialized elements of the array *) +let growArray_iteri (f: int -> 'a -> unit) (ga: 'a growArray) = + for i = 0 to ga.gaMaxInitIndex do + f i ga.gaData.(i) + done + + +(** Fold left over the initialized elements of the array *) +let growArray_foldl (f: 'acc -> 'a -> 'acc) + (acc: 'acc) (ga: 'a growArray) : 'acc = + let rec loop (acc: 'acc) (idx: int) : 'acc = + if idx > ga.gaMaxInitIndex then + acc + else + loop (f acc ga.gaData.(idx)) (idx + 1) + in + loop acc 0 + + + + +let hasPrefix (prefix: string) (what: string) : bool = + let pl = String.length prefix in + try String.sub what 0 pl = prefix + with Invalid_argument _ -> false + + + +let restoreRef ?(deepCopy=(fun x -> x)) (r: 'a ref) : (unit -> unit) = + let old = deepCopy !r in + (fun () -> r := old) + +let restoreHash ?deepCopy (h: ('a, 'b) H.t) : (unit -> unit) = + let old = + match deepCopy with + None -> H.copy h + | Some f -> + let old = H.create (H.length h) in + H.iter (fun k d -> H.add old k (f d)) h; + old + in + (fun () -> hash_copy_into old h) + +let restoreIntHash ?deepCopy (h: 'a IH.t) : (unit -> unit) = + let old = + match deepCopy with + None -> IH.copy h + | Some f -> + let old = IH.create 13 in + IH.iter (fun k d -> IH.add old k (f d)) h; + old + in + (fun () -> + IH.clear old; + IH.iter (fun i k -> IH.add old i k) h) + +let restoreArray ?deepCopy (a: 'a array) : (unit -> unit) = + let old = Array.copy a in + (match deepCopy with + None -> () + | Some f -> Array.iteri (fun i v -> old.(i) <- f v) old); + (fun () -> Array.blit old 0 a 0 (Array.length a)) + +let runThunks (l: (unit -> unit) list) : (unit -> unit) = + fun () -> List.iter (fun f -> f ()) l + + + +(* Memoize *) +let memoize (h: ('a, 'b) Hashtbl.t) + (arg: 'a) + (f: 'a -> 'b) : 'b = + try + Hashtbl.find h arg + with Not_found -> begin + let res = f arg in + Hashtbl.add h arg res; + res + end + +(* Just another name for memoize *) +let findOrAdd h arg f = memoize h arg f + +(* A tryFinally function *) +let tryFinally + (main: 'a -> 'b) (* The function to run *) + (final: 'b option -> unit) (* Something to run at the end *) + (arg: 'a) : 'b = + try + let res: 'b = main arg in + final (Some res); + res + with e -> begin + final None; + raise e + end + + + + +let valOf : 'a option -> 'a = function + None -> raise (Failure "Util.valOf") + | Some x -> x + +(** + * An accumulating for loop. + * + * Initialize the accumulator with init. The current index and accumulator + * from the previous iteration is passed to f. + *) +let fold_for ~(init: 'a) ~(lo: int) ~(hi: int) (f: int -> 'a -> 'a) = + let rec forloop i acc = + if i > hi then acc + else forloop (i+1) (f i acc) + in + forloop lo init + +(************************************************************************) + +module type STACK = sig + type 'a t + (** The type of stacks containing elements of type ['a]. *) + + exception Empty + (** Raised when {!Stack.pop} or {!Stack.top} is applied to an empty stack. *) + + val create : unit -> 'a t + (** Return a new stack, initially empty. *) + + val push : 'a -> 'a t -> unit + (** [push x s] adds the element [x] at the top of stack [s]. *) + + val pop : 'a t -> 'a + (** [pop s] removes and returns the topmost element in stack [s], + or raises [Empty] if the stack is empty. *) + + val top : 'a t -> 'a + (** [top s] returns the topmost element in stack [s], + or raises [Empty] if the stack is empty. *) + + val clear : 'a t -> unit + (** Discard all elements from a stack. *) + + val copy : 'a t -> 'a t + (** Return a copy of the given stack. *) + + val is_empty : 'a t -> bool + (** Return [true] if the given stack is empty, [false] otherwise. *) + + val length : 'a t -> int + (** Return the number of elements in a stack. *) + + val iter : ('a -> unit) -> 'a t -> unit + (** [iter f s] applies [f] in turn to all elements of [s], + from the element at the top of the stack to the element at the + bottom of the stack. The stack itself is unchanged. *) +end + +module Stack = struct + + type 'a t = { mutable length : int; + stack : 'a Stack.t; } + + exception Empty + + let create () = { length = 0; + stack = Stack.create(); } + + let push x s = + s.length <- s.length + 1; + Stack.push x s.stack + + let pop s = + s.length <- s.length - 1; + Stack.pop s.stack + + let top s = + Stack.top s.stack + + let clear s = + s.length <- 0; + Stack.clear s.stack + + let copy s = { length = s.length; + stack = Stack.copy s.stack; } + + let is_empty s = + Stack.is_empty s.stack + + let length s = s.length + + let iter f s = + Stack.iter f s.stack + +end + +(************************************************************************) + +let absoluteFilename (fname: string) = + if Filename.is_relative fname then + Filename.concat (Sys.getcwd ()) fname + else + fname + + +(* mapNoCopy is like map but avoid copying the list if the function does not + * change the elements. *) +let rec mapNoCopy (f: 'a -> 'a) = function + [] -> [] + | (i :: resti) as li -> + let i' = f i in + let resti' = mapNoCopy f resti in + if i' != i || resti' != resti then i' :: resti' else li + +let rec mapNoCopyList (f: 'a -> 'a list) = function + [] -> [] + | (i :: resti) as li -> + let il' = f i in + let resti' = mapNoCopyList f resti in + match il' with + [i'] when i' == i && resti' == resti -> li + | _ -> il' @ resti' + + +(* Use a filter function that does not rewrite the list unless necessary *) +let rec filterNoCopy (f: 'a -> bool) (l: 'a list) : 'a list = + match l with + [] -> [] + | h :: rest when not (f h) -> filterNoCopy f rest + | h :: rest -> + let rest' = filterNoCopy f rest in + if rest == rest' then l else h :: rest' + +(** Join a list of strings *) +let rec joinStrings (sep: string) (sl: string list) = + match sl with + [] -> "" + | [s1] -> s1 + | s1 :: ((_ :: _) as rest) -> s1 ^ sep ^ joinStrings sep rest + + +(************************************************************************ + + Configuration + + ************************************************************************) +(** The configuration data can be of several types **) +type configData = + ConfInt of int + | ConfBool of bool + | ConfFloat of float + | ConfString of string + | ConfList of configData list + + +(* Store here window configuration file *) +let configurationData: (string, configData) H.t = H.create 13 + +let clearConfiguration () = H.clear configurationData + +let setConfiguration (key: string) (c: configData) = + H.replace configurationData key c + +let findConfiguration (key: string) : configData = + H.find configurationData key + +let findConfigurationInt (key: string) : int = + match findConfiguration key with + ConfInt i -> i + | _ -> + ignore (E.warn "Configuration %s is not an integer" key); + raise Not_found + +let useConfigurationInt (key: string) (f: int -> unit) = + try f (findConfigurationInt key) + with Not_found -> () + +let findConfigurationString (key: string) : string = + match findConfiguration key with + ConfString s -> s + | _ -> + ignore (E.warn "Configuration %s is not a string" key); + raise Not_found + +let useConfigurationString (key: string) (f: string -> unit) = + try f (findConfigurationString key) + with Not_found -> () + + +let findConfigurationBool (key: string) : bool = + match findConfiguration key with + ConfBool b -> b + | _ -> + ignore (E.warn "Configuration %s is not a boolean" key); + raise Not_found + +let useConfigurationBool (key: string) (f: bool -> unit) = + try f (findConfigurationBool key) + with Not_found -> () + +let findConfigurationList (key: string) : configData list = + match findConfiguration key with + ConfList l -> l + | _ -> + ignore (E.warn "Configuration %s is not a list" key); + raise Not_found + +let useConfigurationList (key: string) (f: configData list -> unit) = + try f (findConfigurationList key) + with Not_found -> () + + +let saveConfiguration (fname: string) = + (** Convert configuration data to a string, for saving externally *) + let configToString (c: configData) : string = + let buff = Buffer.create 80 in + let rec loop (c: configData) : unit = + match c with + ConfInt i -> + Buffer.add_char buff 'i'; + Buffer.add_string buff (string_of_int i); + Buffer.add_char buff ';' + + | ConfBool b -> + Buffer.add_char buff 'b'; + Buffer.add_string buff (string_of_bool b); + Buffer.add_char buff ';' + + | ConfFloat f -> + Buffer.add_char buff 'f'; + Buffer.add_string buff (string_of_float f); + Buffer.add_char buff ';' + + | ConfString s -> + if String.contains s '"' then + E.s (E.unimp "Guilib: configuration string contains quotes"); + Buffer.add_char buff '"'; + Buffer.add_string buff s; + Buffer.add_char buff '"'; (* '"' *) + + | ConfList l -> + Buffer.add_char buff '['; + List.iter loop l; + Buffer.add_char buff ']' + in + loop c; + Buffer.contents buff + in + try + let oc = open_out fname in + ignore (E.log "Saving configuration to %s\n" (absoluteFilename fname)); + H.iter (fun k c -> + output_string oc (k ^ "\n"); + output_string oc ((configToString c) ^ "\n")) + configurationData; + close_out oc + with _ -> + ignore (E.warn "Cannot open configuration file %s\n" fname) + + +(** Make some regular expressions early *) +let intRegexp = Str.regexp "i\\([0-9]+\\);" +let floatRegexp = Str.regexp "f\\([0-9]+\\.[0-9]+\\);" +let boolRegexp = Str.regexp "b\\(\\(true\\)\\|\\(false\\)\\);" +let stringRegexp = Str.regexp "\"\\([^\"]*\\)\"" + +let loadConfiguration (fname: string) : unit = + H.clear configurationData; + + let stringToConfig (s: string) : configData = + let idx = ref 0 in (** the current index *) + let l = String.length s in + + let rec getOne () : configData = + if !idx >= l then raise Not_found; + + if Str.string_match intRegexp s !idx then begin + idx := Str.match_end (); + ConfInt (int_of_string (Str.matched_group 1 s)) + end else if Str.string_match floatRegexp s !idx then begin + idx := Str.match_end (); + ConfFloat (float_of_string (Str.matched_group 1 s)) + end else if Str.string_match boolRegexp s !idx then begin + idx := Str.match_end (); + ConfBool (bool_of_string (Str.matched_group 1 s)) + end else if Str.string_match stringRegexp s !idx then begin + idx := Str.match_end (); + ConfString (Str.matched_group 1 s) + end else if String.get s !idx = '[' then begin + (* We are starting a list *) + incr idx; + let rec loop (acc: configData list) : configData list = + if !idx >= l then begin + ignore (E.warn "Non-terminated list in configuration %s" s); + raise Not_found + end; + if String.get s !idx = ']' then begin + incr idx; + List.rev acc + end else + loop (getOne () :: acc) + in + ConfList (loop []) + end else begin + ignore (E.warn "Bad configuration element in a list: %s\n" + (String.sub s !idx (l - !idx))); + raise Not_found + end + in + getOne () + in + (try + let ic = open_in fname in + ignore (E.log "Loading configuration from %s\n" (absoluteFilename fname)); + (try + while true do + let k = input_line ic in + let s = input_line ic in + try + let c = stringToConfig s in + setConfiguration k c + with Not_found -> () + done + with End_of_file -> ()); + close_in ic; + with _ -> () (* no file, ignore *)); + + () + + + +(*********************************************************************) +type symbol = int + +(**{ Registering symbol names} *) +let registeredSymbolNames: (string, symbol) H.t = H.create 113 +let symbolNames: string IH.t = IH.create 113 +let nextSymbolId = ref 0 + +(* When we register symbol ranges, we store a naming function for use later + * when we print the symbol *) +let symbolRangeNaming: (int * int * (int -> string)) list ref = ref [] + +(* Reset the symbols. We want to allow the registration of symbols at the + * top-level. This means that we cannot simply clear the hash tables. The + * first time we call "reset" we actually remember the state. *) +let resetThunk: (unit -> unit) option ref = ref None + +let snapshotSymbols () : unit -> unit = + runThunks [ restoreIntHash symbolNames; + restoreRef nextSymbolId; + restoreHash registeredSymbolNames; + restoreRef symbolRangeNaming ] + +let resetSymbols () = + match !resetThunk with + None -> resetThunk := Some (snapshotSymbols ()) + | Some t -> t () + + +let dumpSymbols () = + ignore (E.log "Current symbols\n"); + IH.iter (fun i k -> ignore (E.log " %s -> %d\n" k i)) symbolNames; + () + +let newSymbol (n: string) : symbol = + assert(not (H.mem registeredSymbolNames n)); + let id = !nextSymbolId in + incr nextSymbolId; + H.add registeredSymbolNames n id; + IH.add symbolNames id n; + id + +let registerSymbolName (n: string) : symbol = + try H.find registeredSymbolNames n + with Not_found -> begin + newSymbol n + end + +(** Register a range of symbols. The mkname function will be invoked for + * indices starting at 0 *) +let registerSymbolRange (count: int) (mkname: int -> string) : symbol = + if count < 0 then E.s (E.bug "registerSymbolRange: invalid counter"); + let first = !nextSymbolId in + nextSymbolId := !nextSymbolId + count; + symbolRangeNaming := + (first, !nextSymbolId - 1, mkname) :: !symbolRangeNaming; + first + +let symbolName (id: symbol) : string = + try IH.find symbolNames id + with Not_found -> + (* Perhaps it is one of the lazily named symbols *) + try + let (fst, _, mkname) = + List.find + (fun (fst,lst,_) -> fst <= id && id <= lst) + !symbolRangeNaming in + let n = mkname (id - fst) in + IH.add symbolNames id n; + n + with Not_found -> + ignore (E.warn "Cannot find the name of symbol %d" id); + "symbol" ^ string_of_int id + +(************************************************************************) + +(** {1 Int32 Operators} *) + +module Int32Op = struct + exception IntegerTooLarge + let to_int (i: int32) = + let i' = Int32.to_int i in (* Silently drop the 32nd bit *) + if i = Int32.of_int i' then i' + else raise IntegerTooLarge + + let (<%) = (fun x y -> (Int32.compare x y) < 0) + let (<=%) = (fun x y -> (Int32.compare x y) <= 0) + let (>%) = (fun x y -> (Int32.compare x y) > 0) + let (>=%) = (fun x y -> (Int32.compare x y) >= 0) + let (<>%) = (fun x y -> (Int32.compare x y) <> 0) + + let (+%) = Int32.add + let (-%) = Int32.sub + let ( *% ) = Int32.mul + let (/%) = Int32.div + let (~-%) = Int32.neg + + (* We cannot use the <<% because it trips camlp4 *) + let sll = fun i j -> Int32.shift_left i (to_int j) + let (>>%) = fun i j -> Int32.shift_right i (to_int j) + let (>>>%) = fun i j -> Int32.shift_right_logical i (to_int j) +end + + +(*********************************************************************) + +let equals x1 x2 : bool = + (compare x1 x2) = 0 diff --git a/cil/ocamlutil/util.mli b/cil/ocamlutil/util.mli new file mode 100644 index 0000000..d701c65 --- /dev/null +++ b/cil/ocamlutil/util.mli @@ -0,0 +1,311 @@ +(** A bunch of generally useful functions *) + +exception GotSignal of int + +val withTimeout : float -> (* Seconds for timeout *) + (int -> 'b) -> (* What to do if we have a timeout. The + * argument passed is the signal number + * received. *) + ('a -> 'b) -> (* The function to run *) + 'a -> (* And its argument *) + 'b + +val docHash : ?sep:Pretty.doc -> ('a -> 'b -> Pretty.doc) -> unit -> + (('a, 'b) Hashtbl.t) -> Pretty.doc + + +val hash_to_list: ('a, 'b) Hashtbl.t -> ('a * 'b) list + +val keys: ('a, 'b) Hashtbl.t -> 'a list + + +(** Copy a hash table into another *) +val hash_copy_into: ('a, 'b) Hashtbl.t -> ('a, 'b) Hashtbl.t -> unit + +(** First, a few utility functions I wish were in the standard prelude *) + +val anticompare: 'a -> 'a -> int + +val list_drop : int -> 'a list -> 'a list +val list_droptail : int -> 'a list -> 'a list +val list_span: ('a -> bool) -> ('a list) -> 'a list * 'a list +val list_insert_by: ('a -> 'a -> int) -> 'a -> 'a list -> 'a list +val list_head_default: 'a -> 'a list -> 'a +val list_iter3 : ('a -> 'b -> 'c -> unit) -> + 'a list -> 'b list -> 'c list -> unit +val get_some_option_list : 'a option list -> 'a list +val list_append: ('a list) -> ('a list) -> ('a list) (* tail-recursive append*) + +(** Iterate over a list passing the index as you go *) +val list_iteri: (int -> 'a -> unit) -> 'a list -> unit +val list_mapi: (int -> 'a -> 'b) -> 'a list -> 'b list + +(** Like fold_left but pass the index into the list as well *) +val list_fold_lefti: ('acc -> int -> 'a -> 'acc) -> 'acc -> 'a list -> 'acc + +(** Generates the range of integers starting with a and ending with b *) +val int_range_list : int -> int -> int list + +(* Create a list of length l *) +val list_init : int -> (int -> 'a) -> 'a list + +(** Find the first element in a list that returns Some *) +val list_find_first: 'a list -> ('a -> 'b option) -> 'b option + +(** mapNoCopy is like map but avoid copying the list if the function does not + * change the elements *) + +val mapNoCopy: ('a -> 'a) -> 'a list -> 'a list + +val mapNoCopyList: ('a -> 'a list) -> 'a list -> 'a list + +val filterNoCopy: ('a -> bool) -> 'a list -> 'a list + + +(** Join a list of strings *) +val joinStrings: string -> string list -> string + + +(**** Now in growArray.mli + +(** Growable arrays *) +type 'a growArrayFill = + Elem of 'a + | Susp of (int -> 'a) + +type 'a growArray = { + gaFill: 'a growArrayFill; + (** Stuff to use to fill in the array as it grows *) + + mutable gaMaxInitIndex: int; + (** Maximum index that was written to. -1 if no writes have + * been made. *) + + mutable gaData: 'a array; + } + +val newGrowArray: int -> 'a growArrayFill -> 'a growArray +(** [newGrowArray initsz fillhow] *) + +val getReg: 'a growArray -> int -> 'a +val setReg: 'a growArray -> int -> 'a -> unit +val copyGrowArray: 'a growArray -> 'a growArray +val deepCopyGrowArray: 'a growArray -> ('a -> 'a) -> 'a growArray + + +val growArray_iteri: (int -> 'a -> unit) -> 'a growArray -> unit +(** Iterate over the initialized elements of the array *) + +val growArray_foldl: ('acc -> 'a -> 'acc) -> 'acc ->'a growArray -> 'acc +(** Fold left over the initialized elements of the array *) + +****) + +(** hasPrefix prefix str returns true with str starts with prefix *) +val hasPrefix: string -> string -> bool + + +(** Given a ref cell, produce a thunk that later restores it to its current value *) +val restoreRef: ?deepCopy:('a -> 'a) -> 'a ref -> unit -> unit + +(** Given a hash table, produce a thunk that later restores it to its current value *) +val restoreHash: ?deepCopy:('b -> 'b) -> ('a, 'b) Hashtbl.t -> unit -> unit + +(** Given an integer hash table, produce a thunk that later restores it to + * its current value *) +val restoreIntHash: ?deepCopy:('b -> 'b) -> 'b Inthash.t -> unit -> unit + +(** Given an array, produce a thunk that later restores it to its current value *) +val restoreArray: ?deepCopy:('a -> 'a) -> 'a array -> unit -> unit + + +(** Given a list of thunks, produce a thunk that runs them all *) +val runThunks: (unit -> unit) list -> unit -> unit + + +val memoize: ('a, 'b) Hashtbl.t -> + 'a -> + ('a -> 'b) -> 'b + +(** Just another name for memoize *) +val findOrAdd: ('a, 'b) Hashtbl.t -> + 'a -> + ('a -> 'b) -> 'b + +val tryFinally: + ('a -> 'b) -> (* The function to run *) + ('b option -> unit) -> (* Something to run at the end. The None case is + * used when an exception is thrown *) + 'a -> 'b + + + + +(** Get the value of an option. Raises Failure if None *) +val valOf : 'a option -> 'a + +(** + * An accumulating for loop. + * + * Initialize the accumulator with init. The current index and accumulator + * from the previous iteration is passed to f. + *) +val fold_for : init:'a -> lo:int -> hi:int -> (int -> 'a -> 'a) -> 'a + +(************************************************************************) + +module type STACK = sig + type 'a t + (** The type of stacks containing elements of type ['a]. *) + + exception Empty + (** Raised when {!Util.Stack.pop} or {!Util.Stack.top} is applied to an + * empty stack. *) + + val create : unit -> 'a t + + + val push : 'a -> 'a t -> unit + (** [push x s] adds the element [x] at the top of stack [s]. *) + + val pop : 'a t -> 'a + (** [pop s] removes and returns the topmost element in stack [s], + or raises [Empty] if the stack is empty. *) + + val top : 'a t -> 'a + (** [top s] returns the topmost element in stack [s], + or raises [Empty] if the stack is empty. *) + + val clear : 'a t -> unit + (** Discard all elements from a stack. *) + + val copy : 'a t -> 'a t + (** Return a copy of the given stack. *) + + val is_empty : 'a t -> bool + (** Return [true] if the given stack is empty, [false] otherwise. *) + + val length : 'a t -> int + (** Return the number of elements in a stack. *) + + val iter : ('a -> unit) -> 'a t -> unit + (** [iter f s] applies [f] in turn to all elements of [s], + from the element at the top of the stack to the element at the + bottom of the stack. The stack itself is unchanged. *) +end + +module Stack : STACK + +(************************************************************************ + Configuration +************************************************************************) +(** The configuration data can be of several types **) +type configData = + ConfInt of int + | ConfBool of bool + | ConfFloat of float + | ConfString of string + | ConfList of configData list + + +(** Load the configuration from a file *) +val loadConfiguration: string -> unit + +(** Save the configuration in a file. Overwrites the previous values *) +val saveConfiguration: string -> unit + + +(** Clear all configuration data *) +val clearConfiguration: unit -> unit + +(** Set a configuration element, with a key. Overwrites the previous values *) +val setConfiguration: string -> configData -> unit + +(** Find a configuration elements, given a key. Raises Not_found if it canont + * find it *) +val findConfiguration: string -> configData + +(** Like findConfiguration but extracts the integer *) +val findConfigurationInt: string -> int + +(** Looks for an integer configuration element, and if it is found, it uses + * the given function. Otherwise, does nothing *) +val useConfigurationInt: string -> (int -> unit) -> unit + + +val findConfigurationBool: string -> bool +val useConfigurationBool: string -> (bool -> unit) -> unit + +val findConfigurationString: string -> string +val useConfigurationString: string -> (string -> unit) -> unit + +val findConfigurationList: string -> configData list +val useConfigurationList: string -> (configData list -> unit) -> unit + + +(************************************************************************) + +(** Symbols are integers that are uniquely associated with names *) +type symbol = int + +(** Get the name of a symbol *) +val symbolName: symbol -> string + +(** Register a symbol name and get the symbol for it *) +val registerSymbolName: string -> symbol + +(** Register a number of consecutive symbol ids. The naming function will be + * invoked with indices from 0 to the counter - 1. Returns the id of the + * first symbol created. The naming function is invoked lazily, only when the + * name of the symbol is required. *) +val registerSymbolRange: int -> (int -> string) -> symbol + + +(** Make a fresh symbol. Give the name also, which ought to be distinct from + * existing symbols. This is different from registerSymbolName in that it + * always creates a new symbol. *) +val newSymbol: string -> symbol + +(** Reset the state of the symbols to the program startup state *) +val resetSymbols: unit -> unit + +(** Take a snapshot of the symbol state. Returns a thunk that restores the + * state. *) +val snapshotSymbols: unit -> unit -> unit + + +(** Dump the list of registered symbols *) +val dumpSymbols: unit -> unit + +(************************************************************************) + +(** {1 Int32 Operators} *) + +module Int32Op : sig + val (<%) : int32 -> int32 -> bool + val (<=%) : int32 -> int32 -> bool + val (>%) : int32 -> int32 -> bool + val (>=%) : int32 -> int32 -> bool + val (<>%) : int32 -> int32 -> bool + + val (+%) : int32 -> int32 -> int32 + val (-%) : int32 -> int32 -> int32 + val ( *% ) : int32 -> int32 -> int32 + val (/%) : int32 -> int32 -> int32 + val (~-%) : int32 -> int32 + + val sll : int32 -> int32 -> int32 + val (>>%) : int32 -> int32 -> int32 + val (>>>%) : int32 -> int32 -> int32 + + exception IntegerTooLarge + val to_int : int32 -> int +end + +(************************************************************************) + +(** This has the semantics of (=) on OCaml 3.07 and earlier. It can + handle cyclic values as long as a structure in the cycle has a unique + name or id in some field that occurs before any fields that have cyclic + pointers. *) +val equals: 'a -> 'a -> bool diff --git a/cil/src/check.ml b/cil/src/check.ml new file mode 100644 index 0000000..4dc8850 --- /dev/null +++ b/cil/src/check.ml @@ -0,0 +1,1017 @@ +(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) + +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* A consistency checker for CIL *) +open Cil +module E = Errormsg +module H = Hashtbl +open Pretty + + +(* A few parameters to customize the checking *) +type checkFlags = + NoCheckGlobalIds (* Do not check that the global ids have the proper + * hash value *) + +let checkGlobalIds = ref true + + (* Attributes must be sorted *) +type ctxAttr = + CALocal (* Attribute of a local variable *) + | CAGlobal (* Attribute of a global variable *) + | CAType (* Attribute of a type *) + +let valid = ref true + +let warn fmt = + valid := false; + Cil.warn fmt + +let warnContext fmt = + valid := false; + Cil.warnContext fmt + +let checkAttributes (attrs: attribute list) : unit = + let rec loop lastname = function + [] -> () + | Attr(an, _) :: resta -> + if an < lastname then + ignore (warn "Attributes not sorted"); + loop an resta + in + loop "" attrs + + + (* Keep track of defined types *) +let typeDefs : (string, typ) H.t = H.create 117 + + + (* Keep track of all variables names, enum tags and type names *) +let varNamesEnv : (string, unit) H.t = H.create 117 + + (* We also keep a map of variables indexed by id, to ensure that only one + * varinfo has a given id *) +let varIdsEnv: (int, varinfo) H.t = H.create 117 + + (* And keep track of all varinfo's to check the uniqueness of the + * identifiers *) +let allVarIds: (int, varinfo) H.t = H.create 117 + + (* Also keep a list of environments. We place an empty string in the list to + * mark the start of a local environment (i.e. a function) *) +let varNamesList : (string * int) list ref = ref [] +let defineName s = + if s = "" then + E.s (bug "Empty name\n"); + if H.mem varNamesEnv s then + ignore (warn "Multiple definitions for %s\n" s); + H.add varNamesEnv s () + +let defineVariable vi = + defineName vi.vname; + varNamesList := (vi.vname, vi.vid) :: !varNamesList; + (* Check the id *) + if H.mem allVarIds vi.vid then + ignore (warn "Id %d is already defined (%s)\n" vi.vid vi.vname); + H.add allVarIds vi.vid vi; + (* And register it in the current scope also *) + H.add varIdsEnv vi.vid vi + +(* Check that a varinfo has already been registered *) +let checkVariable vi = + try + (* Check in the current scope only *) + if vi != H.find varIdsEnv vi.vid then + ignore (warnContext "varinfos for %s not shared\n" vi.vname); + with Not_found -> + ignore (warn "Unknown id (%d) for %s\n" vi.vid vi.vname) + + +let startEnv () = + varNamesList := ("", -1) :: !varNamesList + +let endEnv () = + let rec loop = function + [] -> E.s (bug "Cannot find start of env") + | ("", _) :: rest -> varNamesList := rest + | (s, id) :: rest -> begin + H.remove varNamesEnv s; + H.remove varIdsEnv id; + loop rest + end + in + loop !varNamesList + + + +(* The current function being checked *) +let currentReturnType : typ ref = ref voidType + +(* A map of labels in the current function *) +let labels: (string, unit) H.t = H.create 17 + +(* A list of statements seen in the current function *) +let statements: stmt list ref = ref [] + +(* A list of the targets of Gotos *) +let gotoTargets: (string * stmt) list ref = ref [] + +(*** TYPES ***) +(* Cetain types can only occur in some contexts, so keep a list of context *) +type ctxType = + CTStruct (* In a composite type *) + | CTUnion + | CTFArg (* In a function argument type *) + | CTFRes (* In a function result type *) + | CTArray (* In an array type *) + | CTPtr (* In a pointer type *) + | CTExp (* In an expression, as the type of + * the result of binary operators, or + * in a cast *) + | CTSizeof (* In a sizeof *) + | CTDecl (* In a typedef, or a declaration *) + +let d_context () = function + CTStruct -> text "CTStruct" + | CTUnion -> text "CTUnion" + | CTFArg -> text "CTFArg" + | CTFRes -> text "CTFRes" + | CTArray -> text "CTArray" + | CTPtr -> text "CTPtr" + | CTExp -> text "CTExp" + | CTSizeof -> text "CTSizeof" + | CTDecl -> text "CTDecl" + + +(* Keep track of all tags that we use. For each tag remember also the info + * structure and a flag whether it was actually defined or just used. A + * forward declaration acts as a definition. *) +type defuse = + Defined (* We actually have seen a definition of this tag *) + | Forward (* We have seen a forward declaration for it. This is done using + * a GType with an empty type name *) + | Used (* Only uses *) +let compUsed : (int, compinfo * defuse ref) H.t = H.create 117 +let enumUsed : (string, enuminfo * defuse ref) H.t = H.create 117 +let typUsed : (string, typeinfo * defuse ref) H.t = H.create 117 + +(* For composite types we also check that the names are unique *) +let compNames : (string, unit) H.t = H.create 17 + + + (* Check a type *) +let rec checkType (t: typ) (ctx: ctxType) = + (* Check that it appears in the right context *) + let rec checkContext = function + TVoid _ -> ctx = CTPtr || ctx = CTFRes || ctx = CTDecl + | TNamed (ti, a) -> checkContext ti.ttype + | TArray _ -> + (ctx = CTStruct || ctx = CTUnion + || ctx = CTSizeof || ctx = CTDecl || ctx = CTArray || ctx = CTPtr) + | TComp _ -> ctx <> CTExp + | _ -> true + in + if not (checkContext t) then + ignore (warn "Type (%a) used in wrong context. Expected context: %a" + d_plaintype t d_context ctx); + match t with + (TVoid a | TBuiltin_va_list a) -> checkAttributes a + | TInt (ik, a) -> checkAttributes a + | TFloat (_, a) -> checkAttributes a + | TPtr (t, a) -> checkAttributes a; checkType t CTPtr + + | TNamed (ti, a) -> + checkAttributes a; + if ti.tname = "" then + ignore (warnContext "Using a typeinfo for an empty-named type\n"); + checkTypeInfo Used ti + + | TComp (comp, a) -> + checkAttributes a; + (* Mark it as a forward. We'll check it later. If we try to check it + * now we might encounter undefined types *) + checkCompInfo Used comp + + + | TEnum (enum, a) -> begin + checkAttributes a; + checkEnumInfo Used enum + end + + | TArray(bt, len, a) -> + checkAttributes a; + checkType bt CTArray; + (match len with + None -> () + | Some l -> begin + let t = checkExp true l in + match t with + TInt((IInt|IUInt), _) -> () + | _ -> E.s (bug "Type of array length is not integer") + end) + + | TFun (rt, targs, isva, a) -> + checkAttributes a; + checkType rt CTFRes; + List.iter + (fun (an, at, aa) -> + checkType at CTFArg; + checkAttributes aa) (argsToList targs) + +(* Check that a type is a promoted integral type *) +and checkIntegralType (t: typ) = + checkType t CTExp; + match unrollType t with + TInt _ -> () + | _ -> ignore (warn "Non-integral type") + +(* Check that a type is a promoted arithmetic type *) +and checkArithmeticType (t: typ) = + checkType t CTExp; + match unrollType t with + TInt _ | TFloat _ -> () + | _ -> ignore (warn "Non-arithmetic type") + +(* Check that a type is a promoted boolean type *) +and checkBooleanType (t: typ) = + checkType t CTExp; + match unrollType t with + TInt _ | TFloat _ | TPtr _ -> () + | _ -> ignore (warn "Non-boolean type") + + +(* Check that a type is a pointer type *) +and checkPointerType (t: typ) = + checkType t CTExp; + match unrollType t with + TPtr _ -> () + | _ -> ignore (warn "Non-pointer type") + + +and typeMatch (t1: typ) (t2: typ) = + if typeSig t1 <> typeSig t2 then + match unrollType t1, unrollType t2 with + (* Allow free interchange of TInt and TEnum *) + TInt (IInt, _), TEnum _ -> () + | TEnum _, TInt (IInt, _) -> () + + | _, _ -> ignore (warn "Type mismatch:@! %a@!and %a@!" + d_type t1 d_type t2) + +and checkCompInfo (isadef: defuse) comp = + let fullname = compFullName comp in + try + let oldci, olddef = H.find compUsed comp.ckey in + (* Check that it is the same *) + if oldci != comp then + ignore (warnContext "compinfo for %s not shared\n" fullname); + (match !olddef, isadef with + | Defined, Defined -> + ignore (warnContext "Multiple definition of %s\n" fullname) + | _, Defined -> olddef := Defined + | Defined, _ -> () + | _, Forward -> olddef := Forward + | _, _ -> ()) + with Not_found -> begin (* This is the first time we see it *) + (* Check that the name is not empty *) + if comp.cname = "" then + E.s (bug "Compinfo with empty name"); + (* Check that the name is unique *) + if H.mem compNames fullname then + ignore (warn "Duplicate name %s" fullname); + (* Add it to the map before we go on *) + H.add compUsed comp.ckey (comp, ref isadef); + H.add compNames fullname (); + (* Do not check the compinfo unless this is a definition. Otherwise you + * might run into undefined types. *) + if isadef = Defined then begin + checkAttributes comp.cattr; + let fctx = if comp.cstruct then CTStruct else CTUnion in + let rec checkField f = + if not + (f.fcomp == comp && (* Each field must share the self cell of + * the host *) + f.fname <> "") then + ignore (warn "Self pointer not set in field %s of %s" + f.fname fullname); + checkType f.ftype fctx; + (* Check the bitfields *) + (match unrollType f.ftype, f.fbitfield with + | TInt (ik, a), Some w -> + checkAttributes a; + if w < 0 || w >= bitsSizeOf (TInt(ik, a)) then + ignore (warn "Wrong width (%d) in bitfield" w) + | _, Some w -> + ignore (E.error "Bitfield on a non integer type\n") + | _ -> ()); + checkAttributes f.fattr + in + List.iter checkField comp.cfields + end + end + + +and checkEnumInfo (isadef: defuse) enum = + if enum.ename = "" then + E.s (bug "Enuminfo with empty name"); + try + let oldei, olddef = H.find enumUsed enum.ename in + (* Check that it is the same *) + if oldei != enum then + ignore (warnContext "enuminfo for %s not shared\n" enum.ename); + (match !olddef, isadef with + Defined, Defined -> + ignore (warnContext "Multiple definition of enum %s\n" enum.ename) + | _, Defined -> olddef := Defined + | Defined, _ -> () + | _, Forward -> olddef := Forward + | _, _ -> ()) + with Not_found -> begin (* This is the first time we see it *) + (* Add it to the map before we go on *) + H.add enumUsed enum.ename (enum, ref isadef); + checkAttributes enum.eattr; + List.iter (fun (tn, _, _) -> defineName tn) enum.eitems; + end + +and checkTypeInfo (isadef: defuse) ti = + try + let oldti, olddef = H.find typUsed ti.tname in + (* Check that it is the same *) + if oldti != ti then + ignore (warnContext "typeinfo for %s not shared\n" ti.tname); + (match !olddef, isadef with + Defined, Defined -> + ignore (warnContext "Multiple definition of type %s\n" ti.tname) + | Defined, Used -> () + | Used, Defined -> + ignore (warnContext "Use of type %s before its definition\n" ti.tname) + | _, _ -> + ignore (warnContext "Bug in checkTypeInfo for %s\n" ti.tname)) + with Not_found -> begin (* This is the first time we see it *) + if ti.tname = "" then + ignore (warnContext "typeinfo with empty name"); + checkType ti.ttype CTDecl; + (* Add it to the map before we go on *) + H.add typUsed ti.tname (ti, ref isadef); + end + +(* Check an lvalue. If isconst then the lvalue appears in a context where + * only a compile-time constant can appear. Return the type of the lvalue. + * See the typing rule from cil.mli *) +and checkLval (isconst: bool) (lv: lval) : typ = + match lv with + Var vi, off -> + checkVariable vi; + checkOffset vi.vtype off + + | Mem addr, off -> begin + if isconst then + ignore (warn "Memory operation in constant"); + let ta = checkExp false addr in + match unrollType ta with + TPtr (t, _) -> checkOffset t off + | _ -> E.s (bug "Mem on a non-pointer") + end + +(* Check an offset. The basetype is the type of the object referenced by the + * base. Return the type of the lvalue constructed from a base value of right + * type and the offset. See the typing rules from cil.mli *) +and checkOffset basetyp : offset -> typ = function + NoOffset -> basetyp + | Index (ei, o) -> + checkExpType false ei intType; + begin + match unrollType basetyp with + TArray (t, _, _) -> checkOffset t o + | t -> E.s (bug "typeOffset: Index on a non-array: %a" d_plaintype t) + end + + | Field (fi, o) -> + (* Now check that the host is shared propertly *) + checkCompInfo Used fi.fcomp; + (* Check that this exact field is part of the host *) + if not (List.exists (fun f -> f == fi) fi.fcomp.cfields) then + ignore (warn "Field %s not part of %s" + fi.fname (compFullName fi.fcomp)); + checkOffset fi.ftype o + +and checkExpType (isconst: bool) (e: exp) (t: typ) = + let t' = checkExp isconst e in (* compute the type *) + if isconst then begin (* For initializers allow a string to initialize an + * array of characters *) + if typeSig t' <> typeSig t then + match e, t with + | _ -> typeMatch t' t + end else + typeMatch t' t + +(* Check an expression. isconst specifies if the expression occurs in a + * context where only a compile-time constant can occur. Return the computed + * type of the expression *) +and checkExp (isconst: bool) (e: exp) : typ = + E.withContext + (fun _ -> dprintf "check%s: %a" + (if isconst then "Const" else "Exp") d_exp e) + (fun _ -> + match e with + | Const(CInt64 (_, ik, _)) -> TInt(ik, []) + | Const(CChr _) -> charType + | Const(CStr s) -> charPtrType + | Const(CWStr s) -> TPtr(!wcharType,[]) + | Const(CReal (_, fk, _)) -> TFloat(fk, []) + | Const(CEnum (_, _, ei)) -> TEnum(ei, []) + | Lval(lv) -> + if isconst then + ignore (warn "Lval in constant"); + checkLval isconst lv + + | SizeOf(t) -> begin + (* Sizeof cannot be applied to certain types *) + checkType t CTSizeof; + (match unrollType t with + (TFun _ | TVoid _) -> + ignore (warn "Invalid operand for sizeof") + | _ ->()); + uintType + end + | SizeOfE(e) -> + (* The expression in a sizeof can be anything *) + let te = checkExp false e in + checkExp isconst (SizeOf(te)) + + | SizeOfStr s -> uintType + + | AlignOf(t) -> begin + (* Sizeof cannot be applied to certain types *) + checkType t CTSizeof; + (match unrollType t with + (TFun _ | TVoid _) -> + ignore (warn "Invalid operand for sizeof") + | _ ->()); + uintType + end + | AlignOfE(e) -> + (* The expression in an AlignOfE can be anything *) + let te = checkExp false e in + checkExp isconst (AlignOf(te)) + + | UnOp (Neg, e, tres) -> + checkArithmeticType tres; checkExpType isconst e tres; tres + + | UnOp (BNot, e, tres) -> + checkIntegralType tres; checkExpType isconst e tres; tres + + | UnOp (LNot, e, tres) -> + let te = checkExp isconst e in + checkBooleanType te; + checkIntegralType tres; (* Must check that t is well-formed *) + typeMatch tres intType; + tres + + | BinOp (bop, e1, e2, tres) -> begin + let t1 = checkExp isconst e1 in + let t2 = checkExp isconst e2 in + match bop with + (Mult | Div) -> + typeMatch t1 t2; checkArithmeticType tres; + typeMatch t1 tres; tres + | (Eq|Ne|Lt|Le|Ge|Gt) -> + typeMatch t1 t2; checkArithmeticType t1; + typeMatch tres intType; tres + | Mod|BAnd|BOr|BXor -> + typeMatch t1 t2; checkIntegralType tres; + typeMatch t1 tres; tres + | LAnd | LOr -> + typeMatch t1 t2; checkBooleanType tres; + typeMatch t1 tres; tres + | Shiftlt | Shiftrt -> + typeMatch t1 tres; checkIntegralType t1; + checkIntegralType t2; tres + | (PlusA | MinusA) -> + typeMatch t1 t2; typeMatch t1 tres; + checkArithmeticType tres; tres + | (PlusPI | MinusPI | IndexPI) -> + checkPointerType tres; + typeMatch t1 tres; + checkIntegralType t2; + tres + | MinusPP -> + checkPointerType t1; checkPointerType t2; + typeMatch t1 t2; + typeMatch tres intType; + tres + end + | AddrOf (lv) -> begin + let tlv = checkLval isconst lv in + (* Only certain types can be in AddrOf *) + match unrollType tlv with + | TVoid _ -> + E.s (bug "AddrOf on improper type"); + + | (TInt _ | TFloat _ | TPtr _ | TComp _ | TFun _ | TArray _ ) -> + TPtr(tlv, []) + + | TEnum _ -> intPtrType + | _ -> E.s (bug "AddrOf on unknown type") + end + + | StartOf lv -> begin + let tlv = checkLval isconst lv in + match unrollType tlv with + TArray (t,_, _) -> TPtr(t, []) + | _ -> E.s (bug "StartOf on a non-array") + end + + | CastE (tres, e) -> begin + let et = checkExp isconst e in + checkType tres CTExp; + (* Not all types can be cast *) + match unrollType et with + TArray _ -> E.s (bug "Cast of an array type") + | TFun _ -> E.s (bug "Cast of a function type") + | TComp _ -> E.s (bug "Cast of a composite type") + | TVoid _ -> E.s (bug "Cast of a void type") + | _ -> tres + end) + () (* The argument of withContext *) + +and checkInit (i: init) : typ = + E.withContext + (fun _ -> dprintf "checkInit: %a" d_init i) + (fun _ -> + match i with + SingleInit e -> checkExp true e +(* + | ArrayInit (bt, len, initl) -> begin + checkType bt CTSizeof; + if List.length initl > len then + ignore (warn "Too many initializers in array"); + List.iter (fun i -> checkInitType i bt) initl; + TArray(bt, Some (integer len), []) + end +*) + | CompoundInit (ct, initl) -> begin + checkType ct CTSizeof; + (match unrollType ct with + TArray(bt, Some (Const(CInt64(len, _, _))), _) -> + let rec loopIndex i = function + [] -> + if i <> len then + ignore (warn "Wrong number of initializers in array") + + | (Index(Const(CInt64(i', _, _)), NoOffset), ei) :: rest -> + if i' <> i then + ignore (warn "Initializer for index %s when %s was expected\n" + (Int64.format "%d" i') (Int64.format "%d" i)); + checkInitType ei bt; + loopIndex (Int64.succ i) rest + | _ :: rest -> + ignore (warn "Malformed initializer for array element") + in + loopIndex Int64.zero initl + | TArray(_, _, _) -> + ignore (warn "Malformed initializer for array") + | TComp (comp, _) -> + if comp.cstruct then + let rec loopFields + (nextflds: fieldinfo list) + (initl: (offset * init) list) : unit = + match nextflds, initl with + [], [] -> () (* We are done *) + | f :: restf, (Field(f', NoOffset), i) :: resti -> + if f.fname <> f'.fname then + ignore (warn "Expected initializer for field %s and found one for %s\n" f.fname f'.fname); + checkInitType i f.ftype; + loopFields restf resti + | [], _ :: _ -> + ignore (warn "Too many initializers for struct") + | _ :: _, [] -> + ignore (warn "Too few initializers for struct") + | _, _ -> + ignore (warn "Malformed initializer for struct") + in + loopFields + (List.filter (fun f -> f.fname <> missingFieldName) + comp.cfields) + initl + + else (* UNION *) + if comp.cfields == [] then begin + if initl != [] then + ignore (warn "Initializer for empty union not empty"); + end else begin + match initl with + [(Field(f, NoOffset), ei)] -> + if f.fcomp != comp then + ignore (bug "Wrong designator for union initializer"); + if !msvcMode && f != List.hd comp.cfields then + ignore (warn "On MSVC you can only initialize the first field of a union"); + checkInitType ei f.ftype + + | _ -> + ignore (warn "Malformed initializer for union") + end + | _ -> + E.s (warn "Type of Compound is not array or struct or union")); + ct + end) + () (* The arguments of withContext *) + + +and checkInitType (i: init) (t: typ) : unit = + let it = checkInit i in + typeMatch it t + +and checkStmt (s: stmt) = + E.withContext + (fun _ -> + (* Print context only for certain small statements *) + match s.skind with + (*Loop _*) While _ | DoWhile _ | For _ | If _ | Switch _ -> nil + | _ -> dprintf "checkStmt: %a" d_stmt s) + (fun _ -> + (* Check the labels *) + let checkLabel = function + Label (ln, l, _) -> + if H.mem labels ln then + ignore (warn "Multiply defined label %s" ln); + H.add labels ln () + | Case (e, _) -> checkExpType true e intType + | _ -> () (* Not yet implemented *) + in + List.iter checkLabel s.labels; + (* See if we have seen this statement before *) + if List.memq s !statements then + ignore (warn "Statement is shared"); + (* Remember that we have seen this one *) + statements := s :: !statements; + match s.skind with + Break _ | Continue _ -> () + | Goto (gref, l) -> + currentLoc := l; + (* Find a label *) + let lab = + match List.filter (function Label _ -> true | _ -> false) + !gref.labels with + Label (lab, _, _) :: _ -> lab + | _ -> + ignore (warn "Goto to block without a label\n"); + "" + in + (* Remember it as a target *) + gotoTargets := (lab, !gref) :: !gotoTargets + + + | Return (re,l) -> begin + currentLoc := l; + match re, !currentReturnType with + None, TVoid _ -> () + | _, TVoid _ -> ignore (warn "Invalid return value") + | None, _ -> ignore (warn "Invalid return value") + | Some re', rt' -> checkExpType false re' rt' + end +(* + | Loop (b, l, _, _) -> checkBlock b +*) + | While (e, b, l) -> + currentLoc := l; + let te = checkExp false e in + checkBooleanType te; + checkBlock b; + | DoWhile (e, b, l) -> + currentLoc := l; + let te = checkExp false e in + checkBooleanType te; + checkBlock b; + | For (bInit, e, bIter, b, l) -> + currentLoc := l; + checkBlock bInit; + let te = checkExp false e in + checkBooleanType te; + checkBlock bIter; + checkBlock b; + | Block b -> checkBlock b + | If (e, bt, bf, l) -> + currentLoc := l; + let te = checkExp false e in + checkBooleanType te; + checkBlock bt; + checkBlock bf + | Switch (e, b, cases, l) -> + currentLoc := l; + checkExpType false e intType; + (* Remember the statements so far *) + let prevStatements = !statements in + checkBlock b; + (* Now make sure that all the cases do occur in that block *) + List.iter + (fun c -> + if not (List.exists (function Case _ -> true | _ -> false) + c.labels) then + ignore (warn "Case in switch statment without a \"case\"\n"); + (* Make sure it is in there *) + let rec findCase = function + | l when l == prevStatements -> (* Not found *) + ignore (warnContext + "Cannot find target of switch statement") + | [] -> E.s (E.bug "Check: findCase") + | c' :: rest when c == c' -> () (* Found *) + | _ :: rest -> findCase rest + in + findCase !statements) + cases; + | TryFinally (b, h, l) -> + currentLoc := l; + checkBlock b; + checkBlock h + + | TryExcept (b, (il, e), h, l) -> + currentLoc := l; + checkBlock b; + List.iter checkInstr il; + checkExpType false e intType; + checkBlock h + + | Instr il -> List.iter checkInstr il) + () (* argument of withContext *) + +and checkBlock (b: block) : unit = + List.iter checkStmt b.bstmts + + +and checkInstr (i: instr) = + match i with + | Set (dest, e, l) -> + currentLoc := l; + let t = checkLval false dest in + (* Not all types can be assigned to *) + (match unrollType t with + TFun _ -> ignore (warn "Assignment to a function type") + | TArray _ -> ignore (warn "Assignment to an array type") + | TVoid _ -> ignore (warn "Assignment to a void type") + | _ -> ()); + checkExpType false e t + + | Call(dest, what, args, l) -> + currentLoc := l; + let (rt, formals, isva) = + match checkExp false what with + TFun(rt, formals, isva, _) -> rt, formals, isva + | _ -> E.s (bug "Call to a non-function") + in + (* Now check the return value*) + (match dest, unrollType rt with + None, TVoid _ -> () + | Some _, TVoid _ -> ignore (warn "void value is assigned") + | None, _ -> () (* "Call of function is not assigned" *) + | Some destlv, rt' -> + let desttyp = checkLval false destlv in + if typeSig desttyp <> typeSig rt then begin + (* Not all types can be assigned to *) + (match unrollType desttyp with + TFun _ -> ignore (warn "Assignment to a function type") + | TArray _ -> ignore (warn "Assignment to an array type") + | TVoid _ -> ignore (warn "Assignment to a void type") + | _ -> ()); + (* Not all types can be cast *) + (match rt' with + TArray _ -> ignore (warn "Cast of an array type") + | TFun _ -> ignore (warn "Cast of a function type") + | TComp _ -> ignore (warn "Cast of a composite type") + | TVoid _ -> ignore (warn "Cast of a void type") + + | _ -> ()) + end); + (* Now check the arguments *) + let rec loopArgs formals args = + match formals, args with + [], _ when (isva || args = []) -> () + | (fn,ft,_) :: formals, a :: args -> + checkExpType false a ft; + loopArgs formals args + | _, _ -> ignore (warn "Not enough arguments") + in + if formals = None then + ignore (warn "Call to function without prototype\n") + else + loopArgs (argsToList formals) args + + | Asm _ -> () (* Not yet implemented *) + +let rec checkGlobal = function + GAsm _ -> () + | GPragma _ -> () + | GText _ -> () + | GType (ti, l) -> + currentLoc := l; + E.withContext (fun _ -> dprintf "GType(%s)" ti.tname) + (fun _ -> + checkTypeInfo Defined ti; + if ti.tname <> "" then defineName ti.tname) + () + + | GCompTag (comp, l) -> + currentLoc := l; + checkCompInfo Defined comp; + + | GCompTagDecl (comp, l) -> + currentLoc := l; + checkCompInfo Forward comp; + + | GEnumTag (enum, l) -> + currentLoc := l; + checkEnumInfo Defined enum + + | GEnumTagDecl (enum, l) -> + currentLoc := l; + checkEnumInfo Forward enum + + | GVarDecl (vi, l) -> + currentLoc := l; + (* We might have seen it already *) + E.withContext (fun _ -> dprintf "GVarDecl(%s)" vi.vname) + (fun _ -> + (* If we have seen this vid already then it must be for the exact + * same varinfo *) + if H.mem varIdsEnv vi.vid then + checkVariable vi + else begin + defineVariable vi; + checkAttributes vi.vattr; + checkType vi.vtype CTDecl; + if not (vi.vglob && + vi.vstorage <> Register) then + E.s (bug "Invalid declaration of %s" vi.vname) + end) + () + + | GVar (vi, init, l) -> + currentLoc := l; + (* Maybe this is the first occurrence *) + E.withContext (fun _ -> dprintf "GVar(%s)" vi.vname) + (fun _ -> + checkGlobal (GVarDecl (vi, l)); + (* Check the initializer *) + begin match init.init with + None -> () + | Some i -> ignore (checkInitType i vi.vtype) + end; + (* Cannot be a function *) + if isFunctionType vi.vtype then + E.s (bug "GVar for a function (%s)\n" vi.vname); + ) + () + + + | GFun (fd, l) -> begin + currentLoc := l; + (* Check if this is the first occurrence *) + let vi = fd.svar in + let fname = vi.vname in + E.withContext (fun _ -> dprintf "GFun(%s)" fname) + (fun _ -> + checkGlobal (GVarDecl (vi, l)); + (* Check that the argument types in the type are identical to the + * formals *) + let rec loopArgs targs formals = + match targs, formals with + [], [] -> () + | (fn, ft, fa) :: targs, fo :: formals -> + if fn <> fo.vname || ft != fo.vtype || fa != fo.vattr then + ignore (warnContext + "Formal %s not shared (type + locals) in %s" + fo.vname fname); + loopArgs targs formals + + | _ -> + E.s (bug "Type has different number of formals for %s" + fname) + in + begin match vi.vtype with + TFun (rt, args, isva, a) -> begin + currentReturnType := rt; + loopArgs (argsToList args) fd.sformals + end + | _ -> E.s (bug "Function %s does not have a function type" + fname) + end; + ignore (fd.smaxid >= 0 || E.s (bug "smaxid < 0 for %s" fname)); + (* Now start a new environment, in a finally clause *) + begin try + startEnv (); + (* Do the locals *) + let doLocal tctx v = + if v.vglob then + ignore (warnContext + "Local %s has the vglob flag set" v.vname); + if v.vstorage <> NoStorage && v.vstorage <> Register then + ignore (warnContext + "Local %s has storage %a\n" v.vname + d_storage v.vstorage); + checkType v.vtype tctx; + checkAttributes v.vattr; + defineVariable v + in + List.iter (doLocal CTFArg) fd.sformals; + List.iter (doLocal CTDecl) fd.slocals; + statements := []; + gotoTargets := []; + checkBlock fd.sbody; + H.clear labels; + (* Now verify that we have scanned all targets *) + List.iter + (fun (lab, t) -> if not (List.memq t !statements) then + ignore (warnContext + "Target of \"goto %s\" statement does not appear in function body" lab)) + !gotoTargets; + statements := []; + gotoTargets := []; + (* Done *) + endEnv () + with e -> + endEnv (); + raise e + end; + ()) + () (* final argument of withContext *) + end + + +let checkFile flags fl = + if !E.verboseFlag then ignore (E.log "Checking file %s\n" fl.fileName); + valid := true; + List.iter + (function + NoCheckGlobalIds -> checkGlobalIds := false) + flags; + iterGlobals fl (fun g -> try checkGlobal g with _ -> ()); + (* Check that for all struct/union tags there is a definition *) + H.iter + (fun k (comp, isadef) -> + if !isadef = Used then + begin + valid := false; + ignore (E.warn "Compinfo %s is referenced but not defined" + (compFullName comp)) + end) + compUsed; + (* Check that for all enum tags there is a definition *) + H.iter + (fun k (enum, isadef) -> + if !isadef = Used then + begin + valid := false; + ignore (E.warn "Enuminfo %s is referenced but not defined" + enum.ename) + end) + enumUsed; + (* Clean the hashes to let the GC do its job *) + H.clear typeDefs; + H.clear varNamesEnv; + H.clear varIdsEnv; + H.clear allVarIds; + H.clear compNames; + H.clear compUsed; + H.clear enumUsed; + H.clear typUsed; + varNamesList := []; + if !E.verboseFlag then + ignore (E.log "Finished checking file %s\n" fl.fileName); + !valid + diff --git a/cil/src/check.mli b/cil/src/check.mli new file mode 100644 index 0000000..fdcb8b8 --- /dev/null +++ b/cil/src/check.mli @@ -0,0 +1,45 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + (* Checks the well-formedness of the file. Prints warnings and + * returns false if errors are found *) + +type checkFlags = + NoCheckGlobalIds (* Do not check that the global ids have the proper + * hash value *) + +val checkFile: checkFlags list -> Cil.file -> bool diff --git a/cil/src/cil.ml b/cil/src/cil.ml new file mode 100644 index 0000000..2c4e12a --- /dev/null +++ b/cil/src/cil.ml @@ -0,0 +1,6427 @@ +(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) +(* MODIF: useLogicalOperators flag set to true by default. *) + +(* + * + * Copyright (c) 2001-2003, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Ben Liblit + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +open Escape +open Pretty +open Trace (* sm: 'trace' function *) +module E = Errormsg +module H = Hashtbl +module IH = Inthash + +(* + * CIL: An intermediate language for analyzing C progams. + * + * Version Tue Dec 12 15:21:52 PST 2000 + * Scott McPeak, George Necula, Wes Weimer + * + *) + +(* The module Cilversion is generated automatically by Makefile from + * information in configure.in *) +let cilVersion = Cilversion.cilVersion +let cilVersionMajor = Cilversion.cilVersionMajor +let cilVersionMinor = Cilversion.cilVersionMinor +let cilVersionRevision = Cilversion.cilVersionRev + +(* A few globals that control the interpretation of C source *) +let msvcMode = ref false (* Whether the pretty printer should + * print output for the MS VC + * compiler. Default is GCC *) + +let useLogicalOperators = ref (*false*) true + + +module M = Machdep +(* Cil.initCil will set this to the current machine description. + Makefile.cil generates the file obj/@ARCHOS@/machdep.ml, + which contains the descriptions of gcc and msvc. *) +let theMachine : M.mach ref = ref M.gcc + + +let lowerConstants: bool ref = ref true + (** Do lower constants (default true) *) +let insertImplicitCasts: bool ref = ref true + (** Do insert implicit casts (default true) *) + + +let little_endian = ref true +let char_is_unsigned = ref false +let underscore_name = ref false + +type lineDirectiveStyle = + | LineComment + | LinePreprocessorInput + | LinePreprocessorOutput + +let lineDirectiveStyle = ref (Some LinePreprocessorInput) + +let print_CIL_Input = ref false + +let printCilAsIs = ref false + +let lineLength = ref 80 + +(* sm: return the string 's' if we're printing output for gcc, suppres + * it if we're printing for CIL to parse back in. the purpose is to + * hide things from gcc that it complains about, but still be able + * to do lossless transformations when CIL is the consumer *) +let forgcc (s: string) : string = + if (!print_CIL_Input) then "" else s + + +let debugConstFold = false + +(** The Abstract Syntax of CIL *) + + +(** The top-level representation of a CIL source file. Its main contents is + the list of global declarations and definitions. *) +type file = + { mutable fileName: string; (** The complete file name *) + mutable globals: global list; (** List of globals as they will appear + in the printed file *) + mutable globinit: fundec option; + (** An optional global initializer function. This is a function where + * you can put stuff that must be executed before the program is + * started. This function, is conceptually at the end of the file, + * although it is not part of the globals list. Use {!Cil.getGlobInit} + * to create/get one. *) + mutable globinitcalled: bool; + (** Whether the global initialization function is called in main. This + should always be false if there is no global initializer. When + you create a global initialization CIL will try to insert code in + main to call it. *) + } + +and comment = location * string + +(** The main type for representing global declarations and definitions. A list + of these form a CIL file. The order of globals in the file is generally + important. *) +and global = + | GType of typeinfo * location + (** A typedef. All uses of type names (through the [TNamed] constructor) + must be preceeded in the file by a definition of the name. The string + is the defined name and always not-empty. *) + + | GCompTag of compinfo * location + (** Defines a struct/union tag with some fields. There must be one of + these for each struct/union tag that you use (through the [TComp] + constructor) since this is the only context in which the fields are + printed. Consequently nested structure tag definitions must be + broken into individual definitions with the innermost structure + defined first. *) + + | GCompTagDecl of compinfo * location + (** Declares a struct/union tag. Use as a forward declaration. This is + * printed without the fields. *) + + | GEnumTag of enuminfo * location + (** Declares an enumeration tag with some fields. There must be one of + these for each enumeration tag that you use (through the [TEnum] + constructor) since this is the only context in which the items are + printed. *) + + | GEnumTagDecl of enuminfo * location + (** Declares an enumeration tag. Use as a forward declaration. This is + * printed without the items. *) + + | GVarDecl of varinfo * location + (** A variable declaration (not a definition). If the variable has a + function type then this is a prototype. There can be several + declarations and at most one definition for a given variable. If both + forms appear then they must share the same varinfo structure. A + prototype shares the varinfo with the fundec of the definition. Either + has storage Extern or there must be a definition in this file *) + + | GVar of varinfo * initinfo * location + (** A variable definition. Can have an initializer. The initializer is + * updateable so that you can change it without requiring to recreate + * the list of globals. There can be at most one definition for a + * variable in an entire program. Cannot have storage Extern or function + * type. *) + + + | GFun of fundec * location + (** A function definition. *) + + | GAsm of string * location (** Global asm statement. These ones + can contain only a template *) + | GPragma of attribute * location (** Pragmas at top level. Use the same + syntax as attributes *) + | GText of string (** Some text (printed verbatim) at + top level. E.g., this way you can + put comments in the output. *) + + +(** The various types available. Every type is associated with a list of + * attributes, which are always kept in sorted order. Use {!Cil.addAttribute} + * and {!Cil.addAttributes} to construct list of attributes. If you want to + * inspect a type, you should use {!Cil.unrollType} to see through the uses + * of named types. *) +and typ = + TVoid of attributes (** Void type *) + | TInt of ikind * attributes (** An integer type. The kind specifies + the sign and width. *) + | TFloat of fkind * attributes (** A floating-point type. The kind + specifies the precision. *) + + | TPtr of typ * attributes + (** Pointer type. *) + + | TArray of typ * exp option * attributes + (** Array type. It indicates the base type and the array length. *) + + | TFun of typ * (string * typ * attributes) list option * bool * attributes + (** Function type. Indicates the type of the result, the name, type + * and name attributes of the formal arguments ([None] if no + * arguments were specified, as in a function whose definition or + * prototype we have not seen; [Some \[\]] means void). Use + * {!Cil.argsToList} to obtain a list of arguments. The boolean + * indicates if it is a variable-argument function. If this is the + * type of a varinfo for which we have a function declaration then + * the information for the formals must match that in the + * function's sformals. *) + + | TNamed of typeinfo * attributes + (* The use of a named type. All uses of the same type name must + * share the typeinfo. Each such type name must be preceeded + * in the file by a [GType] global. This is printed as just the + * type name. The actual referred type is not printed here and is + * carried only to simplify processing. To see through a sequence + * of named type references, use {!Cil.unrollType}. The attributes + * are in addition to those given when the type name was defined. *) + + | TComp of compinfo * attributes + (** A reference to a struct or a union type. All references to the + same struct or union must share the same compinfo among them and + with a [GCompTag] global that preceeds all uses (except maybe + those that are pointers to the composite type). The attributes + given are those pertaining to this use of the type and are in + addition to the attributes that were given at the definition of + the type and which are stored in the compinfo. *) + + | TEnum of enuminfo * attributes + (** A reference to an enumeration type. All such references must + share the enuminfo among them and with a [GEnumTag] global that + preceeds all uses. The attributes refer to this use of the + enumeration and are in addition to the attributes of the + enumeration itself, which are stored inside the enuminfo *) + + + + | TBuiltin_va_list of attributes + (** This is the same as the gcc's type with the same name *) + +(** Various kinds of integers *) +and ikind = + IChar (** [char] *) + | ISChar (** [signed char] *) + | IUChar (** [unsigned char] *) + | IInt (** [int] *) + | IUInt (** [unsigned int] *) + | IShort (** [short] *) + | IUShort (** [unsigned short] *) + | ILong (** [long] *) + | IULong (** [unsigned long] *) + | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *) + | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft + Visual C) *) + +(** Various kinds of floating-point numbers*) +and fkind = + FFloat (** [float] *) + | FDouble (** [double] *) + | FLongDouble (** [long double] *) + +(** An attribute has a name and some optional parameters *) +and attribute = Attr of string * attrparam list + +(** Attributes are lists sorted by the attribute name *) +and attributes = attribute list + +(** The type of parameters in attributes *) +and attrparam = + | AInt of int (** An integer constant *) + | AStr of string (** A string constant *) + | ACons of string * attrparam list (** Constructed attributes. These + are printed [foo(a1,a2,...,an)]. + The list of parameters can be + empty and in that case the + parentheses are not printed. *) + | ASizeOf of typ (** A way to talk about types *) + | ASizeOfE of attrparam + | ASizeOfS of typsig (** Replacement for ASizeOf in type + signatures. Only used for + attributes inside typsigs.*) + | AAlignOf of typ + | AAlignOfE of attrparam + | AAlignOfS of typsig + | AUnOp of unop * attrparam + | ABinOp of binop * attrparam * attrparam + | ADot of attrparam * string (** a.foo **) + + +(** Information about a composite type (a struct or a union). Use + {!Cil.mkCompInfo} + to create non-recursive or (potentially) recursive versions of this. Make + sure you have a [GCompTag] for each one of these. *) +and compinfo = { + mutable cstruct: bool; (** True if struct, False if union *) + mutable cname: string; (** The name. Always non-empty. Use + * {!Cil.compFullName} to get the + * full name of a comp (along with + * the struct or union) *) + mutable ckey: int; (** A unique integer constructed from + * the name. Use {!Hashtbl.hash} on + * the string returned by + * {!Cil.compFullName}. All compinfo + * for a given key are shared. *) + mutable cfields: fieldinfo list; (** Information about the fields *) + mutable cattr: attributes; (** The attributes that are defined at + the same time as the composite + type *) + mutable cdefined: bool; (** Whether this is a defined + * compinfo. *) + mutable creferenced: bool; (** True if used. Initially set to + * false *) + } + +(** Information about a struct/union field *) +and fieldinfo = { + mutable fcomp: compinfo; (** The compinfo of the host. Note + that this must be shared with the + host since there can be only one + compinfo for a given id *) + mutable fname: string; (** The name of the field. Might be + * the value of + * {!Cil.missingFieldName} in which + * case it must be a bitfield and is + * not printed and it does not + * participate in initialization *) + mutable ftype: typ; (** The type *) + mutable fbitfield: int option; (** If a bitfield then ftype should be + an integer type *) + mutable fattr: attributes; (** The attributes for this field + * (not for its type) *) + mutable floc: location; (** The location where this field + * is defined *) +} + + + +(** Information about an enumeration. This is shared by all references to an + enumeration. Make sure you have a [GEnumTag] for each of of these. *) +and enuminfo = { + mutable ename: string; (** The name. Always non-empty *) + mutable eitems: (string * exp * location) list; (** Items with names + and values. This list + should be + non-empty. The item + values must be + compile-time + constants. *) + mutable eattr: attributes; (** Attributes *) + mutable ereferenced: bool; (** True if used. Initially set to false*) +} + +(** Information about a defined type *) +and typeinfo = { + mutable tname: string; + (** The name. Can be empty only in a [GType] when introducing a composite + * or enumeration tag. If empty cannot be refered to from the file *) + mutable ttype: typ; + (** The actual type. *) + mutable treferenced: bool; + (** True if used. Initially set to false*) +} + + +(** Information about a variable. These structures are shared by all + * references to the variable. So, you can change the name easily, for + * example. Use one of the {!Cil.makeLocalVar}, {!Cil.makeTempVar} or + * {!Cil.makeGlobalVar} to create instances of this data structure. *) +and varinfo = { + mutable vname: string; (** The name of the variable. Cannot + * be empty. *) + mutable vtype: typ; (** The declared type of the + * variable. *) + mutable vattr: attributes; (** A list of attributes associated + * with the variable. *) + mutable vstorage: storage; (** The storage-class *) + (* The other fields are not used in varinfo when they appear in the formal + * argument list in a [TFun] type *) + + + mutable vglob: bool; (** True if this is a global variable*) + + (** Whether this varinfo is for an inline function. *) + mutable vinline: bool; + + mutable vdecl: location; (** Location of variable declaration *) + + mutable vid: int; (** A unique integer identifier. *) + mutable vaddrof: bool; (** True if the address of this + variable is taken. CIL will set + * these flags when it parses C, but + * you should make sure to set the + * flag whenever your transformation + * create [AddrOf] expression. *) + + mutable vreferenced: bool; (** True if this variable is ever + referenced. This is computed by + [removeUnusedVars]. It is safe to + just initialize this to False *) +} + +(** Storage-class information *) +and storage = + NoStorage | (** The default storage. Nothing is + * printed *) + Static | + Register | + Extern + + +(** Expressions (Side-effect free)*) +and exp = + Const of constant (** Constant *) + | Lval of lval (** Lvalue *) + | SizeOf of typ (** sizeof(). Has [unsigned + * int] type (ISO 6.5.3.4). This is + * not turned into a constant because + * some transformations might want to + * change types *) + + | SizeOfE of exp (** sizeof() *) + | SizeOfStr of string + (** sizeof(string_literal). We separate this case out because this is the + * only instance in which a string literal should not be treated as + * having type pointer to character. *) + + | AlignOf of typ (** Has [unsigned int] type *) + | AlignOfE of exp + + + | UnOp of unop * exp * typ (** Unary operation. Includes + the type of the result *) + + | BinOp of binop * exp * exp * typ + (** Binary operation. Includes the + type of the result. The arithemtic + conversions are made explicit + for the arguments *) + | CastE of typ * exp (** Use {!Cil.mkCast} to make casts *) + + | AddrOf of lval (** Always use {!Cil.mkAddrOf} to + * construct one of these. Apply to an + * lvalue of type [T] yields an + * expression of type [TPtr(T)] *) + + | StartOf of lval (** There is no C correspondent for this. C has + * implicit coercions from an array to the address + * of the first element. [StartOf] is used in CIL to + * simplify type checking and is just an explicit + * form of the above mentioned implicit conversion. + * It is not printed. Given an lval of type + * [TArray(T)] produces an expression of type + * [TPtr(T)]. *) + + +(** Literal constants *) +and constant = + | CInt64 of int64 * ikind * string option + (** Integer constant. Give the ikind (see ISO9899 6.1.3.2) + * and the textual representation, if available. Use + * {!Cil.integer} or {!Cil.kinteger} to create these. Watch + * out for integers that cannot be represented on 64 bits. + * OCAML does not give Overflow exceptions. *) + | CStr of string (** String constant (of pointer type) *) + | CWStr of int64 list (** Wide string constant (of type "wchar_t *") *) + | CChr of char (** Character constant. This has type int, so use + * charConstToInt to read the value in case + * sign-extension is needed. *) + | CReal of float * fkind * string option (** Floating point constant. Give + the fkind (see ISO 6.4.4.2) and + also the textual representation, + if available *) + | CEnum of exp * string * enuminfo + (** An enumeration constant with the given value, name, from the given + * enuminfo. This is not used if {!Cil.lowerEnum} is false (default). + * Use {!Cillower.lowerEnumVisitor} to replace these with integer + * constants. *) + +(** Unary operators *) +and unop = + Neg (** Unary minus *) + | BNot (** Bitwise complement (~) *) + | LNot (** Logical Not (!) *) + +(** Binary operations *) +and binop = + PlusA (** arithmetic + *) + | PlusPI (** pointer + integer *) + | IndexPI (** pointer + integer but only when + * it arises from an expression + * [e\[i\]] when [e] is a pointer and + * not an array. This is semantically + * the same as PlusPI but CCured uses + * this as a hint that the integer is + * probably positive. *) + | MinusA (** arithmetic - *) + | MinusPI (** pointer - integer *) + | MinusPP (** pointer - pointer *) + | Mult (** * *) + | Div (** / *) + | Mod (** % *) + | Shiftlt (** shift left *) + | Shiftrt (** shift right *) + + | Lt (** < (arithmetic comparison) *) + | Gt (** > (arithmetic comparison) *) + | Le (** <= (arithmetic comparison) *) + | Ge (** > (arithmetic comparison) *) + | Eq (** == (arithmetic comparison) *) + | Ne (** != (arithmetic comparison) *) + | BAnd (** bitwise and *) + | BXor (** exclusive-or *) + | BOr (** inclusive-or *) + + | LAnd (** logical and *) + | LOr (** logical or *) + + + + +(** An lvalue denotes the contents of a range of memory addresses. This range + * is denoted as a host object along with an offset within the object. The + * host object can be of two kinds: a local or global variable, or an object + * whose address is in a pointer expression. We distinguish the two cases so + * that we can tell quickly whether we are accessing some component of a + * variable directly or we are accessing a memory location through a pointer.*) +and lval = + lhost * offset + +(** The host part of an {!Cil.lval}. *) +and lhost = + | Var of varinfo + (** The host is a variable. *) + + | Mem of exp + (** The host is an object of type [T] when the expression has pointer + * [TPtr(T)]. *) + + +(** The offset part of an {!Cil.lval}. Each offset can be applied to certain + * kinds of lvalues and its effect is that it advances the starting address + * of the lvalue and changes the denoted type, essentially focussing to some + * smaller lvalue that is contained in the original one. *) +and offset = + | NoOffset (** No offset. Can be applied to any lvalue and does + * not change either the starting address or the type. + * This is used when the lval consists of just a host + * or as a terminator in a list of other kinds of + * offsets. *) + + | Field of fieldinfo * offset + (** A field offset. Can be applied only to an lvalue + * that denotes a structure or a union that contains + * the mentioned field. This advances the offset to the + * beginning of the mentioned field and changes the + * type to the type of the mentioned field. *) + + | Index of exp * offset + (** An array index offset. Can be applied only to an + * lvalue that denotes an array. This advances the + * starting address of the lval to the beginning of the + * mentioned array element and changes the denoted type + * to be the type of the array element *) + + + +(* The following equivalences hold *) +(* Mem(AddrOf(Mem a, aoff)), off = Mem a, aoff + off *) +(* Mem(AddrOf(Var v, aoff)), off = Var v, aoff + off *) +(* AddrOf (Mem a, NoOffset) = a *) + +(** Initializers for global variables. You can create an initializer with + * {!Cil.makeZeroInit}. *) +and init = + | SingleInit of exp (** A single initializer *) + | CompoundInit of typ * (offset * init) list + (** Used only for initializers of structures, unions and arrays. + * The offsets are all of the form [Field(f, NoOffset)] or + * [Index(i, NoOffset)] and specify the field or the index being + * initialized. For structures all fields + * must have an initializer (except the unnamed bitfields), in + * the proper order. This is necessary since the offsets are not + * printed. For arrays the list must contain a prefix of the + * initializers; the rest are 0-initialized. + * For unions there must be exactly one initializer. If + * the initializer is not for the first field then a field + * designator is printed, so you better be on GCC since MSVC does + * not understand this. You can scan an initializer list with + * {!Cil.foldLeftCompound}. *) + +(** We want to be able to update an initializer in a global variable, so we + * define it as a mutable field *) +and initinfo = { + mutable init : init option; + } + + +(** Function definitions. *) +and fundec = + { mutable svar: varinfo; + (** Holds the name and type as a variable, so we can refer to it + * easily from the program. All references to this function either + * in a function call or in a prototype must point to the same + * varinfo. *) + mutable sformals: varinfo list; + (** Formals. These must be shared with the formals that appear in the + * type of the function. Use {!Cil.setFormals} or + * {!Cil.setFunctionType} to set these + * formals and ensure that they are reflected in the function type. + * Do not make copies of these because the body refers to them. *) + mutable slocals: varinfo list; + (** Locals. Does not include the sformals. Do not make copies of + * these because the body refers to them. *) + mutable smaxid: int; (** Max local id. Starts at 0. *) + mutable sbody: block; (** The function body. *) + mutable smaxstmtid: int option; (** max id of a (reachable) statement + * in this function, if we have + * computed it. range = 0 ... + * (smaxstmtid-1). This is computed by + * {!Cil.computeCFGInfo}. *) + mutable sallstmts: stmt list; (** After you call {!Cil.computeCFGInfo} + * this field is set to contain all + * statements in the function *) + } + + +(** A block is a sequence of statements with the control falling through from + one element to the next *) +and block = + { mutable battrs: attributes; (** Attributes for the block *) + mutable bstmts: stmt list; (** The statements comprising the block*) + } + + +(** Statements. + The statement is the structural unit in the control flow graph. Use mkStmt + to make a statement and then fill in the fields. *) +and stmt = { + mutable labels: label list; (** Whether the statement starts with + some labels, case statements or + default statement *) + mutable skind: stmtkind; (** The kind of statement *) + + (* Now some additional control flow information. Initially this is not + * filled in. *) + mutable sid: int; (** A number (>= 0) that is unique + in a function. *) + mutable succs: stmt list; (** The successor statements. They can + always be computed from the skind + and the context in which this + statement appears *) + mutable preds: stmt list; (** The inverse of the succs function*) + } + +(** Labels *) +and label = + Label of string * location * bool + (** A real label. If the bool is "true", the label is from the + * input source program. If the bool is "false", the label was + * created by CIL or some other transformation *) + | Case of exp * location (** A case statement *) + | Default of location (** A default statement *) + + + +(* The various kinds of statements *) +and stmtkind = + | Instr of instr list (** A group of instructions that do not + contain control flow. Control + implicitly falls through. *) + | Return of exp option * location (** The return statement. This is a + leaf in the CFG. *) + + | Goto of stmt ref * location (** A goto statement. Appears from + actual goto's in the code. *) + | Break of location (** A break to the end of the nearest + enclosing loop or Switch *) + | Continue of location (** A continue to the start of the + nearest enclosing loop *) + | If of exp * block * block * location (** A conditional. + Two successors, the "then" and + the "else" branches. Both + branches fall-through to the + successor of the If statement *) + | Switch of exp * block * (stmt list) * location + (** A switch statement. The block + contains within all of the cases. + We also have direct pointers to the + statements that implement the + cases. Which cases they implement + you can get from the labels of the + statement *) + +(* + | Loop of block * location * (stmt option) * (stmt option) + (** A [while(1)] loop. The + * termination test is implemented + * in the body of a loop using a + * [Break] statement. If + * prepareCFG has been called, the + * first stmt option will point to + * the stmt containing the + * continue label for this loop + * and the second will point to + * the stmt containing the break + * label for this loop. *) +*) + | While of exp * block * location (** A while loop. *) + | DoWhile of exp * block * location (** A do...while loop. *) + | For of block * exp * block * block * location (** A for loop. *) + + | Block of block (** Just a block of statements. Use it + as a way to keep some attributes + local *) + (** On MSVC we support structured exception handling. This is what you + * might expect. Control can get into the finally block either from the + * end of the body block, or if an exception is thrown. The location + * corresponds to the try keyword. *) + | TryFinally of block * block * location + + (** On MSVC we support structured exception handling. The try/except + * statement is a bit tricky: + __try { blk } + __except (e) { + handler + } + + The argument to __except must be an expression. However, we keep a + list of instructions AND an expression in case you need to make + function calls. We'll print those as a comma expression. The control + can get to the __except expression only if an exception is thrown. + After that, depending on the value of the expression the control + goes to the handler, propagates the exception, or retries the + exception !!! The location corresponds to the try keyword. + *) + | TryExcept of block * (instr list * exp) * block * location + + +(** Instructions. They may cause effects directly but may not have control + flow.*) +and instr = + Set of lval * exp * location (** An assignment. A cast is present + if the exp has different type + from lval *) + | Call of lval option * exp * exp list * location + (** optional: result is an lval. A cast might be + necessary if the declared result type of the + function is not the same as that of the + destination. If the function is declared then + casts are inserted for those arguments that + correspond to declared formals. (The actual + number of arguments might be smaller or larger + than the declared number of arguments. C allows + this.) If the type of the result variable is not + the same as the declared type of the function + result then an implicit cast exists. *) + + (* See the GCC specification for the meaning of ASM. + * If the source is MS VC then only the templates + * are used *) + (* sm: I've added a notes.txt file which contains more + * information on interpreting Asm instructions *) + | Asm of attributes * (* Really only const and volatile can appear + * here *) + string list * (* templates (CR-separated) *) + (string * lval) list * (* outputs must be lvals with + * constraints. I would like these + * to be actually variables, but I + * run into some trouble with ASMs + * in the Linux sources *) + (string * exp) list * (* inputs with constraints *) + string list * (* register clobbers *) + location + (** An inline assembly instruction. The arguments are (1) a list of + attributes (only const and volatile can appear here and only for + GCC), (2) templates (CR-separated), (3) a list of + outputs, each of which is an lvalue with a constraint, (4) a list + of input expressions along with constraints, (5) clobbered + registers, and (5) location information *) + + + +(** Describes a location in a source file *) +and location = { + line: int; (** The line number. -1 means "do not know" *) + file: string; (** The name of the source file*) + byte: int; (** The byte position in the source file *) +} + +(* Type signatures. Two types are identical iff they have identical + * signatures *) +and typsig = + TSArray of typsig * int64 option * attribute list + | TSPtr of typsig * attribute list + | TSComp of bool * string * attribute list + | TSFun of typsig * typsig list * bool * attribute list + | TSEnum of string * attribute list + | TSBase of typ + + + +(** To be able to add/remove features easily, each feature should be package + * as an interface with the following interface. These features should be *) +type featureDescr = { + fd_enabled: bool ref; + (** The enable flag. Set to default value *) + + fd_name: string; + (** This is used to construct an option "--doxxx" and "--dontxxx" that + * enable and disable the feature *) + + fd_description: string; + (* A longer name that can be used to document the new options *) + + fd_extraopt: (string * Arg.spec * string) list; + (** Additional command line options *) + + fd_doit: (file -> unit); + (** This performs the transformation *) + + fd_post_check: bool; + (* Whether to perform a CIL consistency checking after this stage, if + * checking is enabled (--check is passed to cilly) *) +} + +let locUnknown = { line = -1; + file = ""; + byte = -1;} + +(* A reference to the current location *) +let currentLoc : location ref = ref locUnknown + +(* A reference to the current global being visited *) +let currentGlobal: global ref = ref (GText "dummy") + + +let compareLoc (a: location) (b: location) : int = + let namecmp = compare a.file b.file in + if namecmp != 0 + then namecmp + else + let linecmp = a.line - b.line in + if linecmp != 0 + then linecmp + else a.byte - b.byte + +let argsToList : (string * typ * attributes) list option + -> (string * typ * attributes) list + = function + None -> [] + | Some al -> al + + +(* A hack to allow forward reference of d_exp *) +let pd_exp : (unit -> exp -> doc) ref = + ref (fun _ -> E.s (E.bug "pd_exp not initialized")) + +(** Different visiting actions. 'a will be instantiated with [exp], [instr], + etc. *) +type 'a visitAction = + SkipChildren (** Do not visit the children. Return + the node as it is. *) + | DoChildren (** Continue with the children of this + node. Rebuild the node on return + if any of the children changes + (use == test) *) + | ChangeTo of 'a (** Replace the expression with the + given one *) + | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire + exp is replaced by the first + parameter. Then continue with + the children. On return rebuild + the node if any of the children + has changed and then apply the + function on the node *) + + + +(* sm/gn: cil visitor interface for traversing Cil trees. *) +(* Use visitCilStmt and/or visitCilFile to use this. *) +(* Some of the nodes are changed in place if the children are changed. Use + * one of Change... actions if you want to copy the node *) + +(** A visitor interface for traversing CIL trees. Create instantiations of + * this type by specializing the class {!Cil.nopCilVisitor}. *) +class type cilVisitor = object + + method vvdec: varinfo -> varinfo visitAction + (** Invoked for each variable declaration. The subtrees to be traversed + * are those corresponding to the type and attributes of the variable. + * Note that variable declarations are all the [GVar], [GVarDecl], [GFun], + * all the [varinfo] in formals of function types, and the formals and + * locals for function definitions. This means that the list of formals + * in a function definition will be traversed twice, once as part of the + * function type and second as part of the formals in a function + * definition. *) + + method vvrbl: varinfo -> varinfo visitAction + (** Invoked on each variable use. Here only the [SkipChildren] and + * [ChangeTo] actions make sense since there are no subtrees. Note that + * the type and attributes of the variable are not traversed for a + * variable use *) + + method vexpr: exp -> exp visitAction + (** Invoked on each expression occurence. The subtrees are the + * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the + * variable use. *) + + method vlval: lval -> lval visitAction + (** Invoked on each lvalue occurence *) + + method voffs: offset -> offset visitAction + (** Invoked on each offset occurrence that is *not* as part + * of an initializer list specification, i.e. in an lval or + * recursively inside an offset. *) + + method vinitoffs: offset -> offset visitAction + (** Invoked on each offset appearing in the list of a + * CompoundInit initializer. *) + + method vinst: instr -> instr list visitAction + (** Invoked on each instruction occurrence. The [ChangeTo] action can + * replace this instruction with a list of instructions *) + + method vstmt: stmt -> stmt visitAction + (** Control-flow statement. *) + + method vblock: block -> block visitAction (** Block. Replaced in + place. *) + method vfunc: fundec -> fundec visitAction (** Function definition. + Replaced in place. *) + method vglob: global -> global list visitAction (** Global (vars, types, + etc.) *) + method vinit: init -> init visitAction (** Initializers for globals *) + method vtype: typ -> typ visitAction (** Use of some type. Note + * that for structure/union + * and enumeration types the + * definition of the + * composite type is not + * visited. Use [vglob] to + * visit it. *) + method vattr: attribute -> attribute list visitAction + (** Attribute. Each attribute can be replaced by a list *) + method vattrparam: attrparam -> attrparam visitAction + (** Attribute parameters. *) + + (** Add here instructions while visiting to queue them to + * preceede the current statement or instruction being processed *) + method queueInstr: instr list -> unit + + (** Gets the queue of instructions and resets the queue *) + method unqueueInstr: unit -> instr list + +end + +(* the default visitor does nothing at each node, but does *) +(* not stop; hence they return true *) +class nopCilVisitor : cilVisitor = object + method vvrbl (v:varinfo) = DoChildren (* variable *) + method vvdec (v:varinfo) = DoChildren (* variable + * declaration *) + method vexpr (e:exp) = DoChildren (* expression *) + method vlval (l:lval) = DoChildren (* lval (base is 1st + * field) *) + method voffs (o:offset) = DoChildren (* lval or recursive offset *) + method vinitoffs (o:offset) = DoChildren (* initializer offset *) + method vinst (i:instr) = DoChildren (* imperative instruction *) + method vstmt (s:stmt) = DoChildren (* constrol-flow statement *) + method vblock (b: block) = DoChildren + method vfunc (f:fundec) = DoChildren (* function definition *) + method vglob (g:global) = DoChildren (* global (vars, types, etc.) *) + method vinit (i:init) = DoChildren (* global initializers *) + method vtype (t:typ) = DoChildren (* use of some type *) + method vattr (a: attribute) = DoChildren + method vattrparam (a: attrparam) = DoChildren + + val mutable instrQueue = [] + + method queueInstr (il: instr list) = + List.iter (fun i -> instrQueue <- i :: instrQueue) il + + method unqueueInstr () = + let res = List.rev instrQueue in + instrQueue <- []; + res + +end + +let assertEmptyQueue vis = + if vis#unqueueInstr () <> [] then + (* Either a visitor inserted an instruction somewhere that it shouldn't + have (i.e. at the top level rather than inside of a statement), or + there's a bug in the visitor engine. *) + E.s (E.bug "Visitor's instruction queue is not empty.\n You should only use queueInstr inside a function body!"); + () + + +let lu = locUnknown + +(* sm: utility *) +let startsWith (prefix: string) (s: string) : bool = +( + let prefixLen = (String.length prefix) in + (String.length s) >= prefixLen && + (String.sub s 0 prefixLen) = prefix +) + + +let get_instrLoc (inst : instr) = + match inst with + Set(_, _, loc) -> loc + | Call(_, _, _, loc) -> loc + | Asm(_, _, _, _, _, loc) -> loc +let get_globalLoc (g : global) = + match g with + | GFun(_,l) -> (l) + | GType(_,l) -> (l) + | GEnumTag(_,l) -> (l) + | GEnumTagDecl(_,l) -> (l) + | GCompTag(_,l) -> (l) + | GCompTagDecl(_,l) -> (l) + | GVarDecl(_,l) -> (l) + | GVar(_,_,l) -> (l) + | GAsm(_,l) -> (l) + | GPragma(_,l) -> (l) + | GText(_) -> locUnknown + +let rec get_stmtLoc (statement : stmtkind) = + match statement with + Instr([]) -> lu + | Instr(hd::tl) -> get_instrLoc(hd) + | Return(_, loc) -> loc + | Goto(_, loc) -> loc + | Break(loc) -> loc + | Continue(loc) -> loc + | If(_, _, _, loc) -> loc + | Switch (_, _, _, loc) -> loc +(* + | Loop (_, loc, _, _) -> loc +*) + | While (_, _, loc) -> loc + | DoWhile (_, _, loc) -> loc + | For (_, _, _, _, loc) -> loc + | Block b -> if b.bstmts == [] then lu + else get_stmtLoc ((List.hd b.bstmts).skind) + | TryFinally (_, _, l) -> l + | TryExcept (_, _, _, l) -> l + + +(* The next variable identifier to use. Counts up *) +let nextGlobalVID = ref 1 + +(* The next compindo identifier to use. Counts up. *) +let nextCompinfoKey = ref 1 + +(* Some error reporting functions *) +let d_loc (_: unit) (loc: location) : doc = + text loc.file ++ chr ':' ++ num loc.line + +let d_thisloc (_: unit) : doc = d_loc () !currentLoc + +let error (fmt : ('a,unit,doc) format) : 'a = + let f d = + E.hadErrors := true; + ignore (eprintf "@!%t: Error: %a@!" + d_thisloc insert d); + nil + in + Pretty.gprintf f fmt + +let unimp (fmt : ('a,unit,doc) format) : 'a = + let f d = + E.hadErrors := true; + ignore (eprintf "@!%t: Unimplemented: %a@!" + d_thisloc insert d); + nil + in + Pretty.gprintf f fmt + +let bug (fmt : ('a,unit,doc) format) : 'a = + let f d = + E.hadErrors := true; + ignore (eprintf "@!%t: Bug: %a@!" + d_thisloc insert d); + E.showContext (); + nil + in + Pretty.gprintf f fmt + +let errorLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a = + let f d = + E.hadErrors := true; + ignore (eprintf "@!%a: Error: %a@!" + d_loc loc insert d); + E.showContext (); + nil + in + Pretty.gprintf f fmt + +let warn (fmt : ('a,unit,doc) format) : 'a = + let f d = + ignore (eprintf "@!%t: Warning: %a@!" + d_thisloc insert d); + nil + in + Pretty.gprintf f fmt + + +let warnOpt (fmt : ('a,unit,doc) format) : 'a = + let f d = + if !E.warnFlag then + ignore (eprintf "@!%t: Warning: %a@!" + d_thisloc insert d); + nil + in + Pretty.gprintf f fmt + +let warnContext (fmt : ('a,unit,doc) format) : 'a = + let f d = + ignore (eprintf "@!%t: Warning: %a@!" + d_thisloc insert d); + E.showContext (); + nil + in + Pretty.gprintf f fmt + +let warnContextOpt (fmt : ('a,unit,doc) format) : 'a = + let f d = + if !E.warnFlag then + ignore (eprintf "@!%t: Warning: %a@!" + d_thisloc insert d); + E.showContext (); + nil + in + Pretty.gprintf f fmt + +let warnLoc (loc: location) (fmt : ('a,unit,doc) format) : 'a = + let f d = + ignore (eprintf "@!%a: Warning: %a@!" + d_loc loc insert d); + E.showContext (); + nil + in + Pretty.gprintf f fmt + + + +(* Construct an integer. Use only for values that fit on 31 bits. + For larger values, use kinteger *) +let integer (i: int) = Const (CInt64(Int64.of_int i, IInt, None)) + +let zero = integer 0 +let one = integer 1 +let mone = integer (-1) + +(** Given the character c in a (CChr c), sign-extend it to 32 bits. + (This is the official way of interpreting character constants, according to + ISO C 6.4.4.4.10, which says that character constants are chars cast to ints) + Returns CInt64(sign-extened c, IInt, None) *) +let charConstToInt (c: char) : constant = + let c' = Char.code c in + let value = + if c' < 128 + then Int64.of_int c' + else Int64.of_int (c' - 256) + in + CInt64(value, IInt, None) + + +let rec isInteger = function + | Const(CInt64 (n,_,_)) -> Some n + | Const(CChr c) -> isInteger (Const (charConstToInt c)) (* sign-extend *) + | Const(CEnum(v, s, ei)) -> isInteger v + | CastE(_, e) -> isInteger e + | _ -> None + + + +let rec isZero (e: exp) : bool = isInteger e = Some Int64.zero + +let voidType = TVoid([]) +let intType = TInt(IInt,[]) +let uintType = TInt(IUInt,[]) +let longType = TInt(ILong,[]) +let ulongType = TInt(IULong,[]) +let charType = TInt(IChar, []) + +let charPtrType = TPtr(charType,[]) +let charConstPtrType = TPtr(TInt(IChar, [Attr("const", [])]),[]) +let stringLiteralType = ref charPtrType + +let voidPtrType = TPtr(voidType, []) +let intPtrType = TPtr(intType, []) +let uintPtrType = TPtr(uintType, []) + +let doubleType = TFloat(FDouble, []) + + +(* An integer type that fits pointers. Initialized by initCIL *) +let upointType = ref voidType + +(* An integer type that fits wchar_t. Initialized by initCIL *) +let wcharKind = ref IChar +let wcharType = ref voidType + + +(* An integer type that is the type of sizeof. Initialized by initCIL *) +let typeOfSizeOf = ref voidType +let kindOfSizeOf = ref IUInt + +let initCIL_called = ref false + +(** Returns true if and only if the given integer type is signed. *) +let isSigned = function + | IUChar + | IUShort + | IUInt + | IULong + | IULongLong -> + false + | ISChar + | IShort + | IInt + | ILong + | ILongLong -> + true + | IChar -> + not !theMachine.M.char_is_unsigned + +let mkStmt (sk: stmtkind) : stmt = + { skind = sk; + labels = []; + sid = -1; succs = []; preds = [] } + +let mkBlock (slst: stmt list) : block = + { battrs = []; bstmts = slst; } + +let mkEmptyStmt () = mkStmt (Instr []) +let mkStmtOneInstr (i: instr) = mkStmt (Instr [i]) + +let dummyInstr = (Asm([], ["dummy statement!!"], [], [], [], lu)) +let dummyStmt = mkStmt (Instr [dummyInstr]) + +let compactStmts (b: stmt list) : stmt list = + (* Try to compress statements. Scan the list of statements and remember + * the last instrunction statement encountered, along with a Clist of + * instructions in it. *) + let rec compress (lastinstrstmt: stmt) (* Might be dummStmt *) + (lastinstrs: instr Clist.clist) + (body: stmt list) = + let finishLast (tail: stmt list) : stmt list = + if lastinstrstmt == dummyStmt then tail + else begin + lastinstrstmt.skind <- Instr (Clist.toList lastinstrs); + lastinstrstmt :: tail + end + in + match body with + [] -> finishLast [] + | ({skind=Instr il} as s) :: rest -> + let ils = Clist.fromList il in + if lastinstrstmt != dummyStmt && s.labels == [] then + compress lastinstrstmt (Clist.append lastinstrs ils) rest + else + finishLast (compress s ils rest) + + | s :: rest -> + let res = s :: compress dummyStmt Clist.empty rest in + finishLast res + in + compress dummyStmt Clist.empty b + + +(** Construct sorted lists of attributes ***) +let rec addAttribute (Attr(an, _) as a: attribute) (al: attributes) = + let rec insertSorted = function + [] -> [a] + | ((Attr(an0, _) as a0) :: rest) as l -> + if an < an0 then a :: l + else if Util.equals a a0 then l (* Do not add if already in there *) + else a0 :: insertSorted rest (* Make sure we see all attributes with + * this name *) + in + insertSorted al + +(** The second attribute list is sorted *) +and addAttributes al0 (al: attributes) : attributes = + if al0 == [] then al else + List.fold_left (fun acc a -> addAttribute a acc) al al0 + +and dropAttribute (an: string) (al: attributes) = + List.filter (fun (Attr(an', _)) -> an <> an') al + +and dropAttributes (anl: string list) (al: attributes) = + List.fold_left (fun acc an -> dropAttribute an acc) al anl + +and filterAttributes (s: string) (al: attribute list) : attribute list = + List.filter (fun (Attr(an, _)) -> an = s) al + +(* sm: *) +let hasAttribute s al = + (filterAttributes s al <> []) + + +type attributeClass = + AttrName of bool + (* Attribute of a name. If argument is true and we are on MSVC then + * the attribute is printed using __declspec as part of the storage + * specifier *) + | AttrFunType of bool + (* Attribute of a function type. If argument is true and we are on + * MSVC then the attribute is printed just before the function name *) + + | AttrType (* Attribute of a type *) + +(* This table contains the mapping of predefined attributes to classes. + * Extend this table with more attributes as you need. This table is used to + * determine how to associate attributes with names or type during cabs2cil + * conversion *) +let attributeHash: (string, attributeClass) H.t = + let table = H.create 13 in + List.iter (fun a -> H.add table a (AttrName false)) + [ "section"; "constructor"; "destructor"; "unused"; "used"; "weak"; + "no_instrument_function"; "alias"; "no_check_memory_usage"; + "exception"; "model"; (* "restrict"; *) + "aconst"; "__asm__" (* Gcc uses this to specifiy the name to be used in + * assembly for a global *)]; + + (* Now come the MSVC declspec attributes *) + List.iter (fun a -> H.add table a (AttrName true)) + [ "thread"; "naked"; "dllimport"; "dllexport"; + "selectany"; "allocate"; "nothrow"; "novtable"; "property"; "noreturn"; + "uuid"; "align" ]; + + List.iter (fun a -> H.add table a (AttrFunType false)) + [ "format"; "regparm"; "longcall"; + "noinline"; "always_inline"; ]; + + List.iter (fun a -> H.add table a (AttrFunType true)) + [ "stdcall";"cdecl"; "fastcall" ]; + + List.iter (fun a -> H.add table a AttrType) + [ "const"; "volatile"; "restrict"; "mode" ]; + table + + +(* Partition the attributes into classes *) +let partitionAttributes + ~(default:attributeClass) + (attrs: attribute list) : + attribute list * attribute list * attribute list = + let rec loop (n,f,t) = function + [] -> n, f, t + | (Attr(an, _) as a) :: rest -> + match (try H.find attributeHash an with Not_found -> default) with + AttrName _ -> loop (addAttribute a n, f, t) rest + | AttrFunType _ -> + loop (n, addAttribute a f, t) rest + | AttrType -> loop (n, f, addAttribute a t) rest + in + loop ([], [], []) attrs + + +(* Get the full name of a comp *) +let compFullName comp = + (if comp.cstruct then "struct " else "union ") ^ comp.cname + + +let missingFieldName = "___missing_field_name" + +(** Creates a a (potentially recursive) composite type. Make sure you add a + * GTag for it to the file! **) +let mkCompInfo + (isstruct: bool) + (n: string) + (* fspec is a function that when given a forward + * representation of the structure type constructs the type of + * the fields. The function can ignore this argument if not + * constructing a recursive type. *) + (mkfspec: compinfo -> (string * typ * int option * attribute list * + location) list) + (a: attribute list) : compinfo = + + (* make an new name for anonymous structs *) + if n = "" then + E.s (E.bug "mkCompInfo: missing structure name\n"); + (* Make a new self cell and a forward reference *) + let comp = + { cstruct = isstruct; cname = ""; ckey = 0; cfields = []; + cattr = a; creferenced = false; + (* Make this compinfo undefined by default *) + cdefined = false; } + in + comp.cname <- n; + comp.ckey <- !nextCompinfoKey; + incr nextCompinfoKey; + let flds = + List.map (fun (fn, ft, fb, fa, fl) -> + { fcomp = comp; + ftype = ft; + fname = fn; + fbitfield = fb; + fattr = fa; + floc = fl}) (mkfspec comp) in + comp.cfields <- flds; + if flds <> [] then comp.cdefined <- true; + comp + +(** Make a copy of a compinfo, changing the name and the key *) +let copyCompInfo (ci: compinfo) (n: string) : compinfo = + let ci' = {ci with cname = n; + ckey = !nextCompinfoKey; } in + incr nextCompinfoKey; + (* Copy the fields and set the new pointers to parents *) + ci'.cfields <- List.map (fun f -> {f with fcomp = ci'}) ci'.cfields; + ci' + +(**** Utility functions ******) + +let rec typeAttrs = function + TVoid a -> a + | TInt (_, a) -> a + | TFloat (_, a) -> a + | TNamed (t, a) -> addAttributes a (typeAttrs t.ttype) + | TPtr (_, a) -> a + | TArray (_, _, a) -> a + | TComp (comp, a) -> addAttributes comp.cattr a + | TEnum (enum, a) -> addAttributes enum.eattr a + | TFun (_, _, _, a) -> a + | TBuiltin_va_list a -> a + + +let setTypeAttrs t a = + match t with + TVoid _ -> TVoid a + | TInt (i, _) -> TInt (i, a) + | TFloat (f, _) -> TFloat (f, a) + | TNamed (t, _) -> TNamed(t, a) + | TPtr (t', _) -> TPtr(t', a) + | TArray (t', l, _) -> TArray(t', l, a) + | TComp (comp, _) -> TComp (comp, a) + | TEnum (enum, _) -> TEnum (enum, a) + | TFun (r, args, v, _) -> TFun(r,args,v,a) + | TBuiltin_va_list _ -> TBuiltin_va_list a + + +let typeAddAttributes a0 t = +begin + match a0 with + | [] -> + (* no attributes, keep same type *) + t + | _ -> + (* anything else: add a0 to existing attributes *) + let add (a: attributes) = addAttributes a0 a in + match t with + TVoid a -> TVoid (add a) + | TInt (ik, a) -> TInt (ik, add a) + | TFloat (fk, a) -> TFloat (fk, add a) + | TEnum (enum, a) -> TEnum (enum, add a) + | TPtr (t, a) -> TPtr (t, add a) + | TArray (t, l, a) -> TArray (t, l, add a) + | TFun (t, args, isva, a) -> TFun(t, args, isva, add a) + | TComp (comp, a) -> TComp (comp, add a) + | TNamed (t, a) -> TNamed (t, add a) + | TBuiltin_va_list a -> TBuiltin_va_list (add a) +end + +let typeRemoveAttributes (anl: string list) t = + let drop (al: attributes) = dropAttributes anl al in + match t with + TVoid a -> TVoid (drop a) + | TInt (ik, a) -> TInt (ik, drop a) + | TFloat (fk, a) -> TFloat (fk, drop a) + | TEnum (enum, a) -> TEnum (enum, drop a) + | TPtr (t, a) -> TPtr (t, drop a) + | TArray (t, l, a) -> TArray (t, l, drop a) + | TFun (t, args, isva, a) -> TFun(t, args, isva, drop a) + | TComp (comp, a) -> TComp (comp, drop a) + | TNamed (t, a) -> TNamed (t, drop a) + | TBuiltin_va_list a -> TBuiltin_va_list (drop a) + +let unrollType (t: typ) : typ = + let rec withAttrs (al: attributes) (t: typ) : typ = + match t with + TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype + | x -> typeAddAttributes al x + in + withAttrs [] t + +let rec unrollTypeDeep (t: typ) : typ = + let rec withAttrs (al: attributes) (t: typ) : typ = + match t with + TNamed (r, a') -> withAttrs (addAttributes al a') r.ttype + | TPtr(t, a') -> TPtr(unrollTypeDeep t, addAttributes al a') + | TArray(t, l, a') -> TArray(unrollTypeDeep t, l, addAttributes al a') + | TFun(rt, args, isva, a') -> + TFun (unrollTypeDeep rt, + (match args with + None -> None + | Some argl -> + Some (List.map (fun (an,at,aa) -> + (an, unrollTypeDeep at, aa)) argl)), + isva, + addAttributes al a') + | x -> typeAddAttributes al x + in + withAttrs [] t + +let isVoidType t = + match unrollType t with + TVoid _ -> true + | _ -> false +let isVoidPtrType t = + match unrollType t with + TPtr(tau,_) when isVoidType tau -> true + | _ -> false + +let var vi : lval = (Var vi, NoOffset) +(* let assign vi e = Instrs(Set (var vi, e), lu) *) + +let mkString s = Const(CStr s) + + +let mkWhile ~(guard:exp) ~(body: stmt list) : stmt list = + (* Do it like this so that the pretty printer recognizes it *) +(* + [ mkStmt (Loop (mkBlock (mkStmt (If(guard, + mkBlock [ mkEmptyStmt () ], + mkBlock [ mkStmt (Break lu)], lu)) :: + body), lu, None, None)) ] +*) + [ mkStmt (While (guard, mkBlock body, lu)) ] + + + +let mkFor ~(start: stmt list) ~(guard: exp) ~(next: stmt list) + ~(body: stmt list) : stmt list = + (start @ + (mkWhile guard (body @ next))) + + +let mkForIncr ~(iter : varinfo) ~(first: exp) ~stopat:(past: exp) ~(incr: exp) + ~(body: stmt list) : stmt list = + (* See what kind of operator we need *) + let compop, nextop = + match unrollType iter.vtype with + TPtr _ -> Lt, PlusPI + | _ -> Lt, PlusA + in + mkFor + [ mkStmt (Instr [(Set (var iter, first, lu))]) ] + (BinOp(compop, Lval(var iter), past, intType)) + [ mkStmt (Instr [(Set (var iter, + (BinOp(nextop, Lval(var iter), incr, iter.vtype)), + lu))])] + body + + +let rec stripCasts (e: exp) = + match e with CastE(_, e') -> stripCasts e' | _ -> e + + + +(* the name of the C function we call to get ccgr ASTs +external parse : string -> file = "cil_main" +*) +(* + Pretty Printing + *) + +let d_ikind () = function + IChar -> text "char" + | ISChar -> text "signed char" + | IUChar -> text "unsigned char" + | IInt -> text "int" + | IUInt -> text "unsigned int" + | IShort -> text "short" + | IUShort -> text "unsigned short" + | ILong -> text "long" + | IULong -> text "unsigned long" + | ILongLong -> + if !msvcMode then text "__int64" else text "long long" + | IULongLong -> + if !msvcMode then text "unsigned __int64" + else text "unsigned long long" + +let d_fkind () = function + FFloat -> text "float" + | FDouble -> text "double" + | FLongDouble -> text "long double" + +let d_storage () = function + NoStorage -> nil + | Static -> text "static " + | Extern -> text "extern " + | Register -> text "register " + +(* sm: need this value below *) +let mostNeg32BitInt : int64 = (Int64.of_string "-0x80000000") +let mostNeg64BitInt : int64 = (Int64.of_string "-0x8000000000000000") + +(* constant *) +let d_const () c = + match c with + CInt64(_, _, Some s) -> text s (* Always print the text if there is one *) + | CInt64(i, ik, None) -> + (** We must make sure to capture the type of the constant. For some + * constants this is done with a suffix, for others with a cast prefix.*) + let suffix : string = + match ik with + IUInt -> "U" + | ILong -> "L" + | IULong -> "UL" + | ILongLong -> if !msvcMode then "L" else "LL" + | IULongLong -> if !msvcMode then "UL" else "ULL" + | _ -> "" + in + let prefix : string = + if suffix <> "" then "" + else if ik = IInt then "" + else "(" ^ (sprint !lineLength (d_ikind () ik)) ^ ")" + in + (* Watch out here for negative integers that we should be printing as + * large positive ones *) + if i < Int64.zero + && (match ik with + IUInt | IULong | IULongLong | IUChar | IUShort -> true | _ -> false) then + let high = Int64.shift_right i 32 in + if ik <> IULongLong && ik <> ILongLong && high = Int64.of_int (-1) then + (* Print only the low order 32 bits *) + text (prefix ^ "0x" ^ + (Int64.format "%x" + (Int64.logand i (Int64.shift_right_logical high 32)) + ^ suffix)) + else + text (prefix ^ "0x" ^ Int64.format "%x" i ^ suffix) + else ( + if (i = mostNeg32BitInt) then + (* sm: quirk here: if you print -2147483648 then this is two tokens *) + (* in C, and the second one is too large to represent in a signed *) + (* int.. so we do what's done in limits.h, and print (-2147483467-1); *) + (* in gcc this avoids a warning, but it might avoid a real problem *) + (* on another compiler or a 64-bit architecture *) + text (prefix ^ "(-0x7FFFFFFF-1)") + else if (i = mostNeg64BitInt) then + (* The same is true of the largest 64-bit negative. *) + text (prefix ^ "(-0x7FFFFFFFFFFFFFFF-1)") + else + text (prefix ^ (Int64.to_string i ^ suffix)) + ) + + | CStr(s) -> text ("\"" ^ escape_string s ^ "\"") + | CWStr(s) -> + (* text ("L\"" ^ escape_string s ^ "\"") *) + (List.fold_left (fun acc elt -> + acc ++ + if (elt >= Int64.zero && + elt <= (Int64.of_int 255)) then + text (escape_char (Char.chr (Int64.to_int elt))) + else + ( text (Printf.sprintf "\\x%LX\"" elt) ++ break ++ + (text "\"")) + ) (text "L\"") s ) ++ text "\"" + (* we cannot print L"\xabcd" "feedme" as L"\xabcdfeedme" -- + * the former has 7 wide characters and the later has 3. *) + + | CChr(c) -> text ("'" ^ escape_char c ^ "'") + | CReal(_, _, Some s) -> text s + | CReal(f, _, None) -> text (string_of_float f) + | CEnum(_, s, ei) -> text s + + +(* Parentheses level. An expression "a op b" is printed parenthesized if its + * parentheses level is >= that that of its context. Identifiers have the + * lowest level and weakly binding operators (e.g. |) have the largest level. + * The correctness criterion is that a smaller level MUST correspond to a + * stronger precedence! + *) +let derefStarLevel = 20 +let indexLevel = 20 +let arrowLevel = 20 +let addrOfLevel = 30 +let additiveLevel = 60 +let comparativeLevel = 70 +let bitwiseLevel = 75 +let getParenthLevel = function + | BinOp((LAnd | LOr), _,_,_) -> 80 + (* Bit operations. *) + | BinOp((BOr|BXor|BAnd),_,_,_) -> bitwiseLevel (* 75 *) + + (* Comparisons *) + | BinOp((Eq|Ne|Gt|Lt|Ge|Le),_,_,_) -> + comparativeLevel (* 70 *) + (* Additive. Shifts can have higher + * level than + or - but I want + * parentheses around them *) + | BinOp((MinusA|MinusPP|MinusPI|PlusA| + PlusPI|IndexPI|Shiftlt|Shiftrt),_,_,_) + -> additiveLevel (* 60 *) + + (* Multiplicative *) + | BinOp((Div|Mod|Mult),_,_,_) -> 40 + + (* Unary *) + | CastE(_,_) -> 30 + | AddrOf(_) -> 30 + | StartOf(_) -> 30 + | UnOp((Neg|BNot|LNot),_,_) -> 30 + + (* Lvals *) + | Lval(Mem _ , _) -> 20 + | Lval(Var _, (Field _|Index _)) -> 20 + | SizeOf _ | SizeOfE _ | SizeOfStr _ -> 20 + | AlignOf _ | AlignOfE _ -> 20 + + | Lval(Var _, NoOffset) -> 0 (* Plain variables *) + | Const _ -> 0 (* Constants *) + + + +(* Separate out the storage-modifier name attributes *) +let separateStorageModifiers (al: attribute list) = + let isstoragemod (Attr(an, _): attribute) : bool = + try + match H.find attributeHash an with + AttrName issm -> issm + | _ -> E.s (E.bug "separateStorageModifier: %s is not a name attribute" an) + with Not_found -> false + in + let stom, rest = List.partition isstoragemod al in + if not !msvcMode then + stom, rest + else + (* Put back the declspec. Put it without the leading __ since these will + * be added later *) + let stom' = + List.map (fun (Attr(an, args)) -> + Attr("declspec", [ACons(an, args)])) stom in + stom', rest + + +let isIntegralType t = + match unrollType t with + (TInt _ | TEnum _) -> true + | _ -> false + +let isArithmeticType t = + match unrollType t with + (TInt _ | TEnum _ | TFloat _) -> true + | _ -> false + + +let isPointerType t = + match unrollType t with + TPtr _ -> true + | _ -> false + +let isFunctionType t = + match unrollType t with + TFun _ -> true + | _ -> false + +(**** Compute the type of an expression ****) +let rec typeOf (e: exp) : typ = + match e with + | Const(CInt64 (_, ik, _)) -> TInt(ik, []) + + (* Character constants have type int. ISO/IEC 9899:1999 (E), + * section 6.4.4.4 [Character constants], paragraph 10, if you + * don't believe me. *) + | Const(CChr _) -> intType + + (* The type of a string is a pointer to characters ! The only case when + * you would want it to be an array is as an argument to sizeof, but we + * have SizeOfStr for that *) + | Const(CStr s) -> !stringLiteralType + + | Const(CWStr s) -> TPtr(!wcharType,[]) + + | Const(CReal (_, fk, _)) -> TFloat(fk, []) + + | Const(CEnum(_, _, ei)) -> TEnum(ei, []) + + | Lval(lv) -> typeOfLval lv + | SizeOf _ | SizeOfE _ | SizeOfStr _ -> !typeOfSizeOf + | AlignOf _ | AlignOfE _ -> !typeOfSizeOf + | UnOp (_, _, t) -> t + | BinOp (_, _, _, t) -> t + | CastE (t, _) -> t + | AddrOf (lv) -> TPtr(typeOfLval lv, []) + | StartOf (lv) -> begin + match unrollType (typeOfLval lv) with + TArray (t,_, _) -> TPtr(t, []) + | _ -> E.s (E.bug "typeOf: StartOf on a non-array") + end + +and typeOfInit (i: init) : typ = + match i with + SingleInit e -> typeOf e + | CompoundInit (t, _) -> t + +and typeOfLval = function + Var vi, off -> typeOffset vi.vtype off + | Mem addr, off -> begin + match unrollType (typeOf addr) with + TPtr (t, _) -> typeOffset t off + | _ -> E.s (bug "typeOfLval: Mem on a non-pointer") + end + +and typeOffset basetyp = + let blendAttributes baseAttrs = + let (_, _, contageous) = + partitionAttributes ~default:(AttrName false) baseAttrs in + typeAddAttributes contageous + in + function + NoOffset -> basetyp + | Index (_, o) -> begin + match unrollType basetyp with + TArray (t, _, baseAttrs) -> + let elementType = typeOffset t o in + blendAttributes baseAttrs elementType + | t -> E.s (E.bug "typeOffset: Index on a non-array") + end + | Field (fi, o) -> + match unrollType basetyp with + TComp (_, baseAttrs) -> + let fieldType = typeOffset fi.ftype o in + blendAttributes baseAttrs fieldType + | _ -> E.s (bug "typeOffset: Field on a non-compound") + + +(** + ** + ** MACHINE DEPENDENT PART + ** + **) +exception SizeOfError of string * typ + + +(* Get the minimum aligment in bytes for a given type *) +let rec alignOf_int = function + | TInt((IChar|ISChar|IUChar), _) -> 1 + | TInt((IShort|IUShort), _) -> !theMachine.M.alignof_short + | TInt((IInt|IUInt), _) -> !theMachine.M.alignof_int + | TInt((ILong|IULong), _) -> !theMachine.M.alignof_long + | TInt((ILongLong|IULongLong), _) -> !theMachine.M.alignof_longlong + | TEnum _ -> !theMachine.M.alignof_enum + | TFloat(FFloat, _) -> !theMachine.M.alignof_float + | TFloat(FDouble, _) -> !theMachine.M.alignof_double + | TFloat(FLongDouble, _) -> !theMachine.M.alignof_longdouble + | TNamed (t, _) -> alignOf_int t.ttype + | TArray (t, _, _) -> alignOf_int t + | TPtr _ | TBuiltin_va_list _ -> !theMachine.M.alignof_ptr + + (* For composite types get the maximum alignment of any field inside *) + | TComp (c, _) -> + (* On GCC the zero-width fields do not contribute to the alignment. On + * MSVC only those zero-width that _do_ appear after other + * bitfields contribute to the alignment. So we drop those that + * do not occur after othe bitfields *) + let rec dropZeros (afterbitfield: bool) = function + | f :: rest when f.fbitfield = Some 0 && not afterbitfield -> + dropZeros afterbitfield rest + | f :: rest -> f :: dropZeros (f.fbitfield <> None) rest + | [] -> [] + in + let fields = dropZeros false c.cfields in + List.fold_left + (fun sofar f -> + (* Bitfields with zero width do not contribute to the alignment in + * GCC *) + if not !msvcMode && f.fbitfield = Some 0 then sofar else + max sofar (alignOf_int f.ftype)) 1 fields + (* These are some error cases *) + | TFun _ when not !msvcMode -> !theMachine.M.alignof_fun + + | TFun _ as t -> raise (SizeOfError ("function", t)) + | TVoid _ as t -> raise (SizeOfError ("void", t)) + + +let bitsSizeOfInt (ik: ikind): int = + match ik with + | IChar | ISChar | IUChar -> 8 + | IInt | IUInt -> 8 * !theMachine.M.sizeof_int + | IShort | IUShort -> 8 * !theMachine.M.sizeof_short + | ILong | IULong -> 8 * !theMachine.M.sizeof_long + | ILongLong | IULongLong -> 8 * !theMachine.M.sizeof_longlong + +(* Represents an integer as for a given kind. + Returns a flag saying whether the value was changed + during truncation (because it was too large to fit in k). *) +let truncateInteger64 (k: ikind) (i: int64) : int64 * bool = + let nrBits = bitsSizeOfInt k in + let signed = isSigned k in + if nrBits = 64 then + i, false + else begin + let i1 = Int64.shift_left i (64 - nrBits) in + let i2 = + if signed then Int64.shift_right i1 (64 - nrBits) + else Int64.shift_right_logical i1 (64 - nrBits) + in + let truncated = + if i2 = i then false + else + (* Examine the bits that we chopped off. If they are all zero, then + * any difference between i2 and i is due to a simple sign-extension. + * e.g. casting the constant 0x80000000 to int makes it + * 0xffffffff80000000. + * Suppress the truncation warning in this case. *) + let chopped = Int64.shift_right_logical i (64 - nrBits) + in chopped <> Int64.zero + in + i2, truncated + end + +(* Construct an integer constant with possible truncation *) +let kinteger64 (k: ikind) (i: int64) : exp = + let i', truncated = truncateInteger64 k i in + if truncated then + ignore (warnOpt "Truncating integer %s to %s\n" + (Int64.format "0x%x" i) (Int64.format "0x%x" i')); + Const (CInt64(i', k, None)) + +(* Construct an integer of a given kind. *) +let kinteger (k: ikind) (i: int) = kinteger64 k (Int64.of_int i) + + +type offsetAcc = + { oaFirstFree: int; (* The first free bit *) + oaLastFieldStart: int; (* Where the previous field started *) + oaLastFieldWidth: int; (* The width of the previous field. Might not + * be same as FirstFree - FieldStart because + * of internal padding *) + oaPrevBitPack: (int * ikind * int) option; (* If the previous fields + * were packed bitfields, + * the bit where packing + * has started, the ikind + * of the bitfield and the + * width of the ikind *) + } + + +(* GCC version *) +(* Does not use the sofar.oaPrevBitPack *) +let rec offsetOfFieldAcc_GCC (fi: fieldinfo) + (sofar: offsetAcc) : offsetAcc = + (* field type *) + let ftype = unrollType fi.ftype in + let ftypeAlign = 8 * alignOf_int ftype in + let ftypeBits = bitsSizeOf ftype in +(* + if fi.fcomp.cname = "comp2468" || + fi.fcomp.cname = "comp2469" || + fi.fcomp.cname = "comp2470" || + fi.fcomp.cname = "comp2471" || + fi.fcomp.cname = "comp2472" || + fi.fcomp.cname = "comp2473" || + fi.fcomp.cname = "comp2474" || + fi.fcomp.cname = "comp2475" || + fi.fcomp.cname = "comp2476" || + fi.fcomp.cname = "comp2477" || + fi.fcomp.cname = "comp2478" then + + ignore (E.log "offsetOfFieldAcc_GCC(%s of %s:%a%a,firstFree=%d,pack=%a)\n" + fi.fname fi.fcomp.cname + d_type ftype + insert + (match fi.fbitfield with + None -> nil + | Some wdthis -> dprintf ":%d" wdthis) + sofar.oaFirstFree + insert + (match sofar.oaPrevBitPack with + None -> text "None" + | Some (packstart, _, wdpack) -> + dprintf "Some(packstart=%d,wd=%d)" + packstart wdpack)); +*) + match ftype, fi.fbitfield with + (* A width of 0 means that we must end the current packing. It seems that + * GCC pads only up to the alignment boundary for the type of this field. + * *) + | _, Some 0 -> + let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in + { oaFirstFree = firstFree; + oaLastFieldStart = firstFree; + oaLastFieldWidth = 0; + oaPrevBitPack = None } + + (* A bitfield cannot span more alignment boundaries of its type than the + * type itself *) + | _, Some wdthis + when (sofar.oaFirstFree + wdthis + ftypeAlign - 1) / ftypeAlign + - sofar.oaFirstFree / ftypeAlign > ftypeBits / ftypeAlign -> + let start = addTrailing sofar.oaFirstFree ftypeAlign in + { oaFirstFree = start + wdthis; + oaLastFieldStart = start; + oaLastFieldWidth = wdthis; + oaPrevBitPack = None } + + (* Try a simple method. Just put the field down *) + | _, Some wdthis -> + { oaFirstFree = sofar.oaFirstFree + wdthis; + oaLastFieldStart = sofar.oaFirstFree; + oaLastFieldWidth = wdthis; + oaPrevBitPack = None + } + + (* Non-bitfield *) + | _, None -> + (* Align this field *) + let newStart = addTrailing sofar.oaFirstFree ftypeAlign in + { oaFirstFree = newStart + ftypeBits; + oaLastFieldStart = newStart; + oaLastFieldWidth = ftypeBits; + oaPrevBitPack = None; + } + +(* MSVC version *) +and offsetOfFieldAcc_MSVC (fi: fieldinfo) + (sofar: offsetAcc) : offsetAcc = + (* field type *) + let ftype = unrollType fi.ftype in + let ftypeAlign = 8 * alignOf_int ftype in + let ftypeBits = bitsSizeOf ftype in +(* + ignore (E.log "offsetOfFieldAcc_MSVC(%s of %s:%a%a,firstFree=%d, pack=%a)\n" + fi.fname fi.fcomp.cname + d_type ftype + insert + (match fi.fbitfield with + None -> nil + | Some wdthis -> dprintf ":%d" wdthis) + sofar.oaFirstFree + insert + (match sofar.oaPrevBitPack with + None -> text "None" + | Some (prevpack, _, wdpack) -> dprintf "Some(prev=%d,wd=%d)" + prevpack wdpack)); +*) + match ftype, fi.fbitfield, sofar.oaPrevBitPack with + (* Ignore zero-width bitfields that come after non-bitfields *) + | TInt (ikthis, _), Some 0, None -> + let firstFree = sofar.oaFirstFree in + { oaFirstFree = firstFree; + oaLastFieldStart = firstFree; + oaLastFieldWidth = 0; + oaPrevBitPack = None } + + (* If we are in a bitpack and we see a bitfield for a type with the + * different width than the pack, then we finish the pack and retry *) + | _, Some _, Some (packstart, _, wdpack) when wdpack != ftypeBits -> + let firstFree = + if sofar.oaFirstFree = packstart then packstart else + packstart + wdpack + in + offsetOfFieldAcc_MSVC fi + { oaFirstFree = addTrailing firstFree ftypeAlign; + oaLastFieldStart = sofar.oaLastFieldStart; + oaLastFieldWidth = sofar.oaLastFieldWidth; + oaPrevBitPack = None } + + (* A width of 0 means that we must end the current packing. *) + | TInt (ikthis, _), Some 0, Some (packstart, _, wdpack) -> + let firstFree = + if sofar.oaFirstFree = packstart then packstart else + packstart + wdpack + in + let firstFree = addTrailing firstFree ftypeAlign in + { oaFirstFree = firstFree; + oaLastFieldStart = firstFree; + oaLastFieldWidth = 0; + oaPrevBitPack = Some (firstFree, ikthis, ftypeBits) } + + (* Check for a bitfield that fits in the current pack after some other + * bitfields *) + | TInt(ikthis, _), Some wdthis, Some (packstart, ikprev, wdpack) + when packstart + wdpack >= sofar.oaFirstFree + wdthis -> + { oaFirstFree = sofar.oaFirstFree + wdthis; + oaLastFieldStart = sofar.oaFirstFree; + oaLastFieldWidth = wdthis; + oaPrevBitPack = sofar.oaPrevBitPack + } + + + | _, _, Some (packstart, _, wdpack) -> (* Finish up the bitfield pack and + * restart. *) + let firstFree = + if sofar.oaFirstFree = packstart then packstart else + packstart + wdpack + in + offsetOfFieldAcc_MSVC fi + { oaFirstFree = addTrailing firstFree ftypeAlign; + oaLastFieldStart = sofar.oaLastFieldStart; + oaLastFieldWidth = sofar.oaLastFieldWidth; + oaPrevBitPack = None } + + (* No active bitfield pack. But we are seeing a bitfield. *) + | TInt(ikthis, _), Some wdthis, None -> + let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in + { oaFirstFree = firstFree + wdthis; + oaLastFieldStart = firstFree; + oaLastFieldWidth = wdthis; + oaPrevBitPack = Some (firstFree, ikthis, ftypeBits); } + + (* No active bitfield pack. Non-bitfield *) + | _, None, None -> + (* Align this field *) + let firstFree = addTrailing sofar.oaFirstFree ftypeAlign in + { oaFirstFree = firstFree + ftypeBits; + oaLastFieldStart = firstFree; + oaLastFieldWidth = ftypeBits; + oaPrevBitPack = None; + } + + | _, Some _, None -> E.s (E.bug "offsetAcc") + + +and offsetOfFieldAcc ~(fi: fieldinfo) + ~(sofar: offsetAcc) : offsetAcc = + if !msvcMode then offsetOfFieldAcc_MSVC fi sofar + else offsetOfFieldAcc_GCC fi sofar + +(* The size of a type, in bits. If struct or array then trailing padding is + * added *) +and bitsSizeOf t = + if not !initCIL_called then + E.s (E.error "You did not call Cil.initCIL before using the CIL library"); + match t with + | TInt (ik,_) -> bitsSizeOfInt ik + | TFloat(FDouble, _) -> 8 * !theMachine.M.sizeof_double + | TFloat(FLongDouble, _) -> 8 * !theMachine.M.sizeof_longdouble + | TFloat _ -> 8 * !theMachine.M.sizeof_float + | TEnum _ -> 8 * !theMachine.M.sizeof_enum + | TPtr _ -> 8 * !theMachine.M.sizeof_ptr + | TBuiltin_va_list _ -> 8 * !theMachine.M.sizeof_ptr + | TNamed (t, _) -> bitsSizeOf t.ttype + | TComp (comp, _) when comp.cfields == [] -> begin + (* Empty structs are allowed in msvc mode *) + if not comp.cdefined && not !msvcMode then + raise (SizeOfError ("abstract type", t)) (*abstract type*) + else + 0 + end + + | TComp (comp, _) when comp.cstruct -> (* Struct *) + (* Go and get the last offset *) + let startAcc = + { oaFirstFree = 0; + oaLastFieldStart = 0; + oaLastFieldWidth = 0; + oaPrevBitPack = None; + } in + let lastoff = + List.fold_left (fun acc fi -> offsetOfFieldAcc ~fi ~sofar:acc) + startAcc comp.cfields + in + if !msvcMode && lastoff.oaFirstFree = 0 && comp.cfields <> [] then + (* On MSVC if we have just a zero-width bitfields then the length + * is 32 and is not padded *) + 32 + else + addTrailing lastoff.oaFirstFree (8 * alignOf_int t) + + | TComp (comp, _) -> (* when not comp.cstruct *) + (* Get the maximum of all fields *) + let startAcc = + { oaFirstFree = 0; + oaLastFieldStart = 0; + oaLastFieldWidth = 0; + oaPrevBitPack = None; + } in + let max = + List.fold_left (fun acc fi -> + let lastoff = offsetOfFieldAcc ~fi ~sofar:startAcc in + if lastoff.oaFirstFree > acc then + lastoff.oaFirstFree else acc) 0 comp.cfields in + (* Add trailing by simulating adding an extra field *) + addTrailing max (8 * alignOf_int t) + + | TArray(t, Some len, _) -> begin + match constFold true len with + Const(CInt64(l,_,_)) -> + addTrailing ((bitsSizeOf t) * (Int64.to_int l)) (8 * alignOf_int t) + | _ -> raise (SizeOfError ("array non-constant length", t)) + end + + + | TVoid _ -> 8 * !theMachine.M.sizeof_void + | TFun _ when not !msvcMode -> (* On GCC the size of a function is defined *) + 8 * !theMachine.M.sizeof_fun + + | TArray (_, None, _) -> (* it seems that on GCC the size of such an + * array is 0 *) + 0 + + | TFun _ -> raise (SizeOfError ("function", t)) + + +and addTrailing nrbits roundto = + (nrbits + roundto - 1) land (lnot (roundto - 1)) + +and sizeOf t = + try + integer ((bitsSizeOf t) lsr 3) + with SizeOfError _ -> SizeOf(t) + + +and bitsOffset (baset: typ) (off: offset) : int * int = + let rec loopOff (baset: typ) (width: int) (start: int) = function + NoOffset -> start, width + | Index(e, off) -> begin + let ei = + match isInteger e with + Some i64 -> Int64.to_int i64 + | None -> raise (SizeOfError ("index not constant", baset)) + in + let bt = + match unrollType baset with + TArray(bt, _, _) -> bt + | _ -> E.s (E.bug "bitsOffset: Index on a non-array") + in + let bitsbt = bitsSizeOf bt in + loopOff bt bitsbt (start + ei * bitsbt) off + end + | Field(f, off) when not f.fcomp.cstruct -> + (* All union fields start at offset 0 *) + loopOff f.ftype (bitsSizeOf f.ftype) start off + + | Field(f, off) -> + (* Construct a list of fields preceeding and including this one *) + let prevflds = + let rec loop = function + [] -> E.s (E.bug "bitsOffset: Cannot find field %s in %s\n" + f.fname f.fcomp.cname) + | fi' :: _ when fi' == f -> [fi'] + | fi' :: rest -> fi' :: loop rest + in + loop f.fcomp.cfields + in + let lastoff = + List.fold_left (fun acc fi' -> offsetOfFieldAcc ~fi:fi' ~sofar:acc) + { oaFirstFree = 0; (* Start at 0 because each struct is done + * separately *) + oaLastFieldStart = 0; + oaLastFieldWidth = 0; + oaPrevBitPack = None } prevflds + in + (* ignore (E.log "Field %s of %s: start=%d, lastFieldStart=%d\n" + f.fname f.fcomp.cname start lastoff.oaLastFieldStart); *) + loopOff f.ftype lastoff.oaLastFieldWidth + (start + lastoff.oaLastFieldStart) off + in + loopOff baset (bitsSizeOf baset) 0 off + + + + +(*** Constant folding. If machdep is true then fold even sizeof operations ***) +and constFold (machdep: bool) (e: exp) : exp = + match e with + BinOp(bop, e1, e2, tres) -> constFoldBinOp machdep bop e1 e2 tres + | UnOp(unop, e1, tres) -> begin + try + let tk = + match unrollType tres with + TInt(ik, _) -> ik + | TEnum _ -> IInt + | _ -> raise Not_found (* probably a float *) + in + match constFold machdep e1 with + Const(CInt64(i,ik,_)) -> begin + match unop with + Neg -> kinteger64 tk (Int64.neg i) + | BNot -> kinteger64 tk (Int64.lognot i) + | LNot -> if i = Int64.zero then one else zero + end + | e1c -> UnOp(unop, e1c, tres) + with Not_found -> e + end + (* Characters are integers *) + | Const(CChr c) -> Const(charConstToInt c) + | Const(CEnum (v, _, _)) -> constFold machdep v + | SizeOf t when machdep -> begin + try + let bs = bitsSizeOf t in + kinteger !kindOfSizeOf (bs / 8) + with SizeOfError _ -> e + end + | SizeOfE e when machdep -> constFold machdep (SizeOf (typeOf e)) + | SizeOfStr s when machdep -> kinteger !kindOfSizeOf (1 + String.length s) + | AlignOf t when machdep -> kinteger !kindOfSizeOf (alignOf_int t) + | AlignOfE e when machdep -> begin + (* The alignmetn of an expression is not always the alignment of its + * type. I know that for strings this is not true *) + match e with + Const (CStr _) when not !msvcMode -> + kinteger !kindOfSizeOf !theMachine.M.alignof_str + (* For an array, it is the alignment of the array ! *) + | _ -> constFold machdep (AlignOf (typeOf e)) + end + + | CastE(it, + AddrOf (Mem (CastE(TPtr(bt, _), z)), off)) + when machdep && isZero z -> begin + try + let start, width = bitsOffset bt off in + if start mod 8 <> 0 then + E.s (error "Using offset of bitfield\n"); + constFold machdep (CastE(it, (integer (start / 8)))) + with SizeOfError _ -> e + end + + + | CastE (t, e) -> begin + match constFold machdep e, unrollType t with + (* Might truncate silently *) + Const(CInt64(i,k,_)), TInt(nk,_) -> + let i', _ = truncateInteger64 nk i in + Const(CInt64(i', nk, None)) + | e', _ -> CastE (t, e') + end + + | _ -> e + +and constFoldBinOp (machdep: bool) bop e1 e2 tres = + let e1' = constFold machdep e1 in + let e2' = constFold machdep e2 in + if isIntegralType tres then begin + let newe = + let rec mkInt = function + Const(CChr c) -> Const(charConstToInt c) + | Const(CEnum (v, s, ei)) -> mkInt v + | CastE(TInt (ik, ta), e) -> begin + match mkInt e with + Const(CInt64(i, _, _)) -> + let i', _ = truncateInteger64 ik i in + Const(CInt64(i', ik, None)) + + | e' -> CastE(TInt(ik, ta), e') + end + | e -> e + in + let tk = + match unrollType tres with + TInt(ik, _) -> ik + | TEnum _ -> IInt + | _ -> E.s (bug "constFoldBinOp") + in + (* See if the result is unsigned *) + let isunsigned typ = not (isSigned typ) in + let ge (unsigned: bool) (i1: int64) (i2: int64) : bool = + if unsigned then + let l1 = Int64.shift_right_logical i1 1 in + let l2 = Int64.shift_right_logical i2 1 in (* Both positive now *) + (l1 > l2) || (l1 = l2 && + Int64.logand i1 Int64.one >= Int64.logand i2 Int64.one) + else i1 >= i2 + in + let shiftInBounds i2 = + (* We only try to fold shifts if the second arg is positive and + less than 64. Otherwise, the semantics are processor-dependent, + so let the compiler sort it out. *) + i2 >= Int64.zero && i2 < (Int64.of_int 64) + in + (* Assume that the necessary promotions have been done *) + match bop, mkInt e1', mkInt e2' with + | PlusA, Const(CInt64(z,_,_)), e2'' when z = Int64.zero -> e2'' + | PlusA, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1'' + | PlusPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1'' + | IndexPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1'' + | MinusPI, e1'', Const(CInt64(z,_,_)) when z = Int64.zero -> e1'' + | PlusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> + kinteger64 tk (Int64.add i1 i2) + | MinusA, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> + kinteger64 tk (Int64.sub i1 i2) + | Mult, Const(CInt64(i1,ik1,_)), Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> + kinteger64 tk (Int64.mul i1 i2) + | Mult, Const(CInt64(0L,_,_)), _ -> zero + | Mult, Const(CInt64(1L,_,_)), e2'' -> e2'' + | Mult, _, Const(CInt64(0L,_,_)) -> zero + | Mult, e1'', Const(CInt64(1L,_,_)) -> e1'' + | Div, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin + try kinteger64 tk (Int64.div i1 i2) + with Division_by_zero -> BinOp(bop, e1', e2', tres) + end + | Div, e1'', Const(CInt64(1L,_,_)) -> e1'' + + | Mod, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> begin + try kinteger64 tk (Int64.rem i1 i2) + with Division_by_zero -> BinOp(bop, e1', e2', tres) + end + | BAnd, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> + kinteger64 tk (Int64.logand i1 i2) + | BAnd, Const(CInt64(0L,_,_)), _ -> zero + | BAnd, _, Const(CInt64(0L,_,_)) -> zero + | BOr, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> + kinteger64 tk (Int64.logor i1 i2) + | BOr, _, _ when isZero e1' -> e2' + | BOr, _, _ when isZero e2' -> e1' + | BXor, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> + kinteger64 tk (Int64.logxor i1 i2) + + | Shiftlt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,_,_)) when shiftInBounds i2 -> + kinteger64 tk (Int64.shift_left i1 (Int64.to_int i2)) + | Shiftlt, Const(CInt64(0L,_,_)), _ -> zero + | Shiftlt, e1'', Const(CInt64(0L,_,_)) -> e1'' + + | Shiftrt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,_,_)) when shiftInBounds i2 -> + if isunsigned ik1 then + kinteger64 tk (Int64.shift_right_logical i1 (Int64.to_int i2)) + else + kinteger64 tk (Int64.shift_right i1 (Int64.to_int i2)) + | Shiftrt, Const(CInt64(0L,_,_)), _ -> zero + | Shiftrt, e1'', Const(CInt64(0L,_,_)) -> e1'' + + | Eq, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> + integer (if i1 = i2 then 1 else 0) + | Ne, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> + integer (if i1 <> i2 then 1 else 0) + | Le, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> + integer (if ge (isunsigned ik1) i2 i1 then 1 else 0) + + | Ge, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> + integer (if ge (isunsigned ik1) i1 i2 then 1 else 0) + + | Lt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> + integer (if i1 <> i2 && ge (isunsigned ik1) i2 i1 then 1 else 0) + + | Gt, Const(CInt64(i1,ik1,_)),Const(CInt64(i2,ik2,_)) when ik1 = ik2 -> + integer (if i1 <> i2 && ge (isunsigned ik1) i1 i2 then 1 else 0) + | LAnd, _, _ when isZero e1' || isZero e2' -> zero + | LOr, _, _ when isZero e1' -> e2' + | LOr, _, _ when isZero e2' -> e1' + | _ -> BinOp(bop, e1', e2', tres) + in + if debugConstFold then + ignore (E.log "Folded %a to %a\n" + (!pd_exp) (BinOp(bop, e1', e2', tres)) (!pd_exp) newe); + newe + end else + BinOp(bop, e1', e2', tres) + + + +let parseInt (str: string) : exp = + let hasSuffix str = + let l = String.length str in + fun s -> + let ls = String.length s in + l >= ls && s = String.uppercase (String.sub str (l - ls) ls) + in + let l = String.length str in + (* See if it is octal or hex *) + let octalhex = (l >= 1 && String.get str 0 = '0') in + (* The length of the suffix and a list of possible kinds. See ISO + * 6.4.4.1 *) + let hasSuffix = hasSuffix str in + let suffixlen, kinds = + if hasSuffix "ULL" || hasSuffix "LLU" then + 3, [IULongLong] + else if hasSuffix "LL" then + 2, if octalhex then [ILongLong; IULongLong] else [ILongLong] + else if hasSuffix "UL" || hasSuffix "LU" then + 2, [IULong; IULongLong] + else if hasSuffix "L" then + 1, if octalhex then [ILong; IULong; ILongLong; IULongLong] + else [ILong; ILongLong] + else if hasSuffix "U" then + 1, [IUInt; IULong; IULongLong] + else if (!msvcMode && hasSuffix "UI64") then + 4, [IULongLong] + else if (!msvcMode && hasSuffix "I64") then + 3, [ILongLong] + else + 0, if octalhex || true (* !!! This is against the ISO but it + * is what GCC and MSVC do !!! *) + then [IInt; IUInt; ILong; IULong; ILongLong; IULongLong] + else [IInt; ILong; IUInt; ILongLong] + in + (* Convert to integer. To prevent overflow we do the arithmetic + * on Int64 and we take care of overflow. We work only with + * positive integers since the lexer takes care of the sign *) + let rec toInt (base: int64) (acc: int64) (idx: int) : int64 = + let doAcc (what: int) = + let acc' = + Int64.add (Int64.mul base acc) (Int64.of_int what) in + if acc < Int64.zero || (* We clearly overflow since base >= 2 + * *) + (acc' > Int64.zero && acc' < acc) then + E.s (unimp "Cannot represent on 64 bits the integer %s\n" + str) + else + toInt base acc' (idx + 1) + in + if idx >= l - suffixlen then begin + acc + end else + let ch = String.get str idx in + if ch >= '0' && ch <= '9' then + doAcc (Char.code ch - Char.code '0') + else if ch >= 'a' && ch <= 'f' then + doAcc (10 + Char.code ch - Char.code 'a') + else if ch >= 'A' && ch <= 'F' then + doAcc (10 + Char.code ch - Char.code 'A') + else + E.s (bug "Invalid integer constant: %s (char %c at idx=%d)" + str ch idx) + in + try + let i = + if octalhex then + if l >= 2 && + (let c = String.get str 1 in c = 'x' || c = 'X') then + toInt (Int64.of_int 16) Int64.zero 2 + else + toInt (Int64.of_int 8) Int64.zero 1 + else + toInt (Int64.of_int 10) Int64.zero 0 + in + (* Construct an integer of the first kinds that fits. i must be + * POSITIVE *) + let res = + let rec loop = function + | ((IInt | ILong) as k) :: _ + when i < Int64.shift_left (Int64.of_int 1) 31 -> + kinteger64 k i + | ((IUInt | IULong) as k) :: _ + when i < Int64.shift_left (Int64.of_int 1) 32 + -> kinteger64 k i + | (ILongLong as k) :: _ + when i <= Int64.sub (Int64.shift_left + (Int64.of_int 1) 63) + (Int64.of_int 1) + -> + kinteger64 k i + | (IULongLong as k) :: _ -> kinteger64 k i + | _ :: rest -> loop rest + | [] -> E.s (E.unimp "Cannot represent the integer %s\n" + (Int64.to_string i)) + in + loop kinds + in + res + with e -> begin + ignore (E.log "int_of_string %s (%s)\n" str + (Printexc.to_string e)); + zero + end + + + +let d_unop () u = + match u with + Neg -> text "-" + | BNot -> text "~" + | LNot -> text "!" + +let d_binop () b = + match b with + PlusA | PlusPI | IndexPI -> text "+" + | MinusA | MinusPP | MinusPI -> text "-" + | Mult -> text "*" + | Div -> text "/" + | Mod -> text "%" + | Shiftlt -> text "<<" + | Shiftrt -> text ">>" + | Lt -> text "<" + | Gt -> text ">" + | Le -> text "<=" + | Ge -> text ">=" + | Eq -> text "==" + | Ne -> text "!=" + | BAnd -> text "&" + | BXor -> text "^" + | BOr -> text "|" + | LAnd -> text "&&" + | LOr -> text "||" + +let invalidStmt = mkStmt (Instr []) + +(** Construct a hash with the builtins *) +let gccBuiltins : (string, typ * typ list * bool) H.t = + let h = H.create 17 in + (* See if we have builtin_va_list *) + let hasbva = M.gccHas__builtin_va_list in + let ulongLongType = TInt(IULongLong, []) in + let floatType = TFloat(FFloat, []) in + let longDoubleType = TFloat (FLongDouble, []) in + let voidConstPtrType = TPtr(TVoid [Attr ("const", [])], []) in + let sizeType = uintType in + + H.add h "__builtin___fprintf_chk" (intType, [ voidPtrType; intType; charConstPtrType ], true) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *); + H.add h "__builtin___memcpy_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false); + H.add h "__builtin___memmove_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false); + H.add h "__builtin___mempcpy_chk" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType; sizeType ], false); + H.add h "__builtin___memset_chk" (voidPtrType, [ voidPtrType; intType; sizeType; sizeType ], false); + H.add h "__builtin___printf_chk" (intType, [ intType; charConstPtrType ], true); + H.add h "__builtin___snprintf_chk" (intType, [ charPtrType; sizeType; intType; sizeType; charConstPtrType ], true); + H.add h "__builtin___sprintf_chk" (intType, [ charPtrType; intType; sizeType; charConstPtrType ], true); + H.add h "__builtin___stpcpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false); + H.add h "__builtin___strcat_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false); + H.add h "__builtin___strcpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false); + H.add h "__builtin___strncat_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType; sizeType ], false); + H.add h "__builtin___strncpy_chk" (charPtrType, [ charPtrType; charConstPtrType; sizeType; sizeType ], false); + H.add h "__builtin___vfprintf_chk" (intType, [ voidPtrType; intType; charConstPtrType; TBuiltin_va_list [] ], false) (* first argument is really FILE*, not void*, but we don't want to build in the definition for FILE *); + H.add h "__builtin___vprintf_chk" (intType, [ intType; charConstPtrType; TBuiltin_va_list [] ], false); + H.add h "__builtin___vsnprintf_chk" (intType, [ charPtrType; sizeType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ], false); + H.add h "__builtin___vsprintf_chk" (intType, [ charPtrType; intType; sizeType; charConstPtrType; TBuiltin_va_list [] ], false); + + H.add h "__builtin_acos" (doubleType, [ doubleType ], false); + H.add h "__builtin_acosf" (floatType, [ floatType ], false); + H.add h "__builtin_acosl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_alloca" (voidPtrType, [ uintType ], false); + + H.add h "__builtin_asin" (doubleType, [ doubleType ], false); + H.add h "__builtin_asinf" (floatType, [ floatType ], false); + H.add h "__builtin_asinl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_atan" (doubleType, [ doubleType ], false); + H.add h "__builtin_atanf" (floatType, [ floatType ], false); + H.add h "__builtin_atanl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_atan2" (doubleType, [ doubleType; doubleType ], false); + H.add h "__builtin_atan2f" (floatType, [ floatType; floatType ], false); + H.add h "__builtin_atan2l" (longDoubleType, [ longDoubleType; + longDoubleType ], false); + + H.add h "__builtin_ceil" (doubleType, [ doubleType ], false); + H.add h "__builtin_ceilf" (floatType, [ floatType ], false); + H.add h "__builtin_ceill" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_cos" (doubleType, [ doubleType ], false); + H.add h "__builtin_cosf" (floatType, [ floatType ], false); + H.add h "__builtin_cosl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_cosh" (doubleType, [ doubleType ], false); + H.add h "__builtin_coshf" (floatType, [ floatType ], false); + H.add h "__builtin_coshl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_clz" (intType, [ uintType ], false); + H.add h "__builtin_clzl" (intType, [ ulongType ], false); + H.add h "__builtin_clzll" (intType, [ ulongLongType ], false); + H.add h "__builtin_constant_p" (intType, [ intType ], false); + H.add h "__builtin_ctz" (intType, [ uintType ], false); + H.add h "__builtin_ctzl" (intType, [ ulongType ], false); + H.add h "__builtin_ctzll" (intType, [ ulongLongType ], false); + + H.add h "__builtin_exp" (doubleType, [ doubleType ], false); + H.add h "__builtin_expf" (floatType, [ floatType ], false); + H.add h "__builtin_expl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_expect" (longType, [ longType; longType ], false); + + H.add h "__builtin_fabs" (doubleType, [ doubleType ], false); + H.add h "__builtin_fabsf" (floatType, [ floatType ], false); + H.add h "__builtin_fabsl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_ffs" (intType, [ uintType ], false); + H.add h "__builtin_ffsl" (intType, [ ulongType ], false); + H.add h "__builtin_ffsll" (intType, [ ulongLongType ], false); + H.add h "__builtin_frame_address" (voidPtrType, [ uintType ], false); + + H.add h "__builtin_floor" (doubleType, [ doubleType ], false); + H.add h "__builtin_floorf" (floatType, [ floatType ], false); + H.add h "__builtin_floorl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_huge_val" (doubleType, [], false); + H.add h "__builtin_huge_valf" (floatType, [], false); + H.add h "__builtin_huge_vall" (longDoubleType, [], false); + H.add h "__builtin_inf" (doubleType, [], false); + H.add h "__builtin_inff" (floatType, [], false); + H.add h "__builtin_infl" (longDoubleType, [], false); + H.add h "__builtin_memcpy" (voidPtrType, [ voidPtrType; voidConstPtrType; uintType ], false); + H.add h "__builtin_mempcpy" (voidPtrType, [ voidPtrType; voidConstPtrType; sizeType ], false); + + H.add h "__builtin_fmod" (doubleType, [ doubleType ], false); + H.add h "__builtin_fmodf" (floatType, [ floatType ], false); + H.add h "__builtin_fmodl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_frexp" (doubleType, [ doubleType; intPtrType ], false); + H.add h "__builtin_frexpf" (floatType, [ floatType; intPtrType ], false); + H.add h "__builtin_frexpl" (longDoubleType, [ longDoubleType; + intPtrType ], false); + + H.add h "__builtin_ldexp" (doubleType, [ doubleType; intType ], false); + H.add h "__builtin_ldexpf" (floatType, [ floatType; intType ], false); + H.add h "__builtin_ldexpl" (longDoubleType, [ longDoubleType; + intType ], false); + + H.add h "__builtin_log" (doubleType, [ doubleType ], false); + H.add h "__builtin_logf" (floatType, [ floatType ], false); + H.add h "__builtin_logl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_log10" (doubleType, [ doubleType ], false); + H.add h "__builtin_log10f" (floatType, [ floatType ], false); + H.add h "__builtin_log10l" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_modff" (floatType, [ floatType; + TPtr(floatType,[]) ], false); + H.add h "__builtin_modfl" (longDoubleType, [ longDoubleType; + TPtr(longDoubleType, []) ], + false); + + H.add h "__builtin_nan" (doubleType, [ charConstPtrType ], false); + H.add h "__builtin_nanf" (floatType, [ charConstPtrType ], false); + H.add h "__builtin_nanl" (longDoubleType, [ charConstPtrType ], false); + H.add h "__builtin_nans" (doubleType, [ charConstPtrType ], false); + H.add h "__builtin_nansf" (floatType, [ charConstPtrType ], false); + H.add h "__builtin_nansl" (longDoubleType, [ charConstPtrType ], false); + H.add h "__builtin_next_arg" ((if hasbva then TBuiltin_va_list [] else voidPtrType), [], false) (* When we parse builtin_next_arg we drop the second argument *); + H.add h "__builtin_object_size" (sizeType, [ voidPtrType; intType ], false); + + H.add h "__builtin_parity" (intType, [ uintType ], false); + H.add h "__builtin_parityl" (intType, [ ulongType ], false); + H.add h "__builtin_parityll" (intType, [ ulongLongType ], false); + + H.add h "__builtin_popcount" (intType, [ uintType ], false); + H.add h "__builtin_popcountl" (intType, [ ulongType ], false); + H.add h "__builtin_popcountll" (intType, [ ulongLongType ], false); + + H.add h "__builtin_powi" (doubleType, [ doubleType; intType ], false); + H.add h "__builtin_powif" (floatType, [ floatType; intType ], false); + H.add h "__builtin_powil" (longDoubleType, [ longDoubleType; intType ], false); + H.add h "__builtin_prefetch" (voidType, [ voidConstPtrType ], true); + H.add h "__builtin_return" (voidType, [ voidConstPtrType ], false); + H.add h "__builtin_return_address" (voidPtrType, [ uintType ], false); + + H.add h "__builtin_sin" (doubleType, [ doubleType ], false); + H.add h "__builtin_sinf" (floatType, [ floatType ], false); + H.add h "__builtin_sinl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_sinh" (doubleType, [ doubleType ], false); + H.add h "__builtin_sinhf" (floatType, [ floatType ], false); + H.add h "__builtin_sinhl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_sqrt" (doubleType, [ doubleType ], false); + H.add h "__builtin_sqrtf" (floatType, [ floatType ], false); + H.add h "__builtin_sqrtl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_stpcpy" (charPtrType, [ charPtrType; charConstPtrType ], false); + H.add h "__builtin_strchr" (charPtrType, [ charPtrType; charType ], false); + H.add h "__builtin_strcmp" (intType, [ charConstPtrType; charConstPtrType ], false); + H.add h "__builtin_strcpy" (charPtrType, [ charPtrType; charConstPtrType ], false); + H.add h "__builtin_strcspn" (uintType, [ charConstPtrType; charConstPtrType ], false); + H.add h "__builtin_strncat" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false); + H.add h "__builtin_strncmp" (intType, [ charConstPtrType; charConstPtrType; sizeType ], false); + H.add h "__builtin_strncpy" (charPtrType, [ charPtrType; charConstPtrType; sizeType ], false); + H.add h "__builtin_strspn" (intType, [ charConstPtrType; charConstPtrType ], false); + H.add h "__builtin_strpbrk" (charPtrType, [ charConstPtrType; charConstPtrType ], false); + (* When we parse builtin_types_compatible_p, we change its interface *) + H.add h "__builtin_types_compatible_p" + (intType, [ uintType; (* Sizeof the type *) + uintType (* Sizeof the type *) ], + false); + H.add h "__builtin_tan" (doubleType, [ doubleType ], false); + H.add h "__builtin_tanf" (floatType, [ floatType ], false); + H.add h "__builtin_tanl" (longDoubleType, [ longDoubleType ], false); + + H.add h "__builtin_tanh" (doubleType, [ doubleType ], false); + H.add h "__builtin_tanhf" (floatType, [ floatType ], false); + H.add h "__builtin_tanhl" (longDoubleType, [ longDoubleType ], false); + + + if hasbva then begin + H.add h "__builtin_va_end" (voidType, [ TBuiltin_va_list [] ], false); + H.add h "__builtin_varargs_start" + (voidType, [ TBuiltin_va_list [] ], false); + H.add h "__builtin_va_start" (voidType, [ TBuiltin_va_list [] ], false); + (* When we parse builtin_stdarg_start, we drop the second argument *) + H.add h "__builtin_stdarg_start" (voidType, [ TBuiltin_va_list []; ], + false); + (* When we parse builtin_va_arg we change its interface *) + H.add h "__builtin_va_arg" (voidType, [ TBuiltin_va_list []; + uintType; (* Sizeof the type *) + voidPtrType; (* Ptr to res *) ], + false); + H.add h "__builtin_va_copy" (voidType, [ TBuiltin_va_list []; + TBuiltin_va_list [] ], + false); + end; + h + +(** Construct a hash with the builtins *) +let msvcBuiltins : (string, typ * typ list * bool) H.t = + (* These are empty for now but can be added to depending on the application*) + let h = H.create 17 in + (** Take a number of wide string literals *) + H.add h "__annotation" (voidType, [ ], true); + h + + + +let pTypeSig : (typ -> typsig) ref = + ref (fun _ -> E.s (E.bug "pTypeSig not initialized")) + + +(** A printer interface for CIL trees. Create instantiations of + * this type by specializing the class {!Cil.defaultCilPrinter}. *) +class type cilPrinter = object + method pVDecl: unit -> varinfo -> doc + (** Invoked for each variable declaration. Note that variable + * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo] + * in formals of function types, and the formals and locals for function + * definitions. *) + + method pVar: varinfo -> doc + (** Invoked on each variable use. *) + + method pLval: unit -> lval -> doc + (** Invoked on each lvalue occurence *) + + method pOffset: doc -> offset -> doc + (** Invoked on each offset occurence. The second argument is the base. *) + + method pInstr: unit -> instr -> doc + (** Invoked on each instruction occurrence. *) + + method pStmt: unit -> stmt -> doc + (** Control-flow statement. This is used by + * {!Cil.printGlobal} and by {!Cil.dumpGlobal}. *) + + method dStmt: out_channel -> int -> stmt -> unit + (** Dump a control-flow statement to a file with a given indentation. This is used by + * {!Cil.dumpGlobal}. *) + + method dBlock: out_channel -> int -> block -> unit + (** Dump a control-flow block to a file with a given indentation. This is + * used by {!Cil.dumpGlobal}. *) + + method pBlock: unit -> block -> Pretty.doc + (** Print a block. *) + + method pGlobal: unit -> global -> doc + (** Global (vars, types, etc.). This can be slow and is used only by + * {!Cil.printGlobal} but by {!Cil.dumpGlobal} for everything else except + * [GVar] and [GFun]. *) + + method dGlobal: out_channel -> global -> unit + (** Dump a global to a file. This is used by {!Cil.dumpGlobal}. *) + + method pFieldDecl: unit -> fieldinfo -> doc + (** A field declaration *) + + method pType: doc option -> unit -> typ -> doc + (* Use of some type in some declaration. The first argument is used to print + * the declared element, or is None if we are just printing a type with no + * name being decalred. Note that for structure/union and enumeration types + * the definition of the composite type is not visited. Use [vglob] to + * visit it. *) + + method pAttr: attribute -> doc * bool + (** Attribute. Also return an indication whether this attribute must be + * printed inside the __attribute__ list or not. *) + + method pAttrParam: unit -> attrparam -> doc + (** Attribute paramter *) + + method pAttrs: unit -> attributes -> doc + (** Attribute lists *) + + method pLabel: unit -> label -> doc + (** Label *) + + method pLineDirective: ?forcefile:bool -> location -> Pretty.doc + (** Print a line-number. This is assumed to come always on an empty line. + * If the forcefile argument is present and is true then the file name + * will be printed always. Otherwise the file name is printed only if it + * is different from the last time time this function is called. The last + * file name is stored in a private field inside the cilPrinter object. *) + + method pStmtKind : stmt -> unit -> stmtkind -> Pretty.doc + (** Print a statement kind. The code to be printed is given in the + * {!Cil.stmtkind} argument. The initial {!Cil.stmt} argument + * records the statement which follows the one being printed; + * {!Cil.defaultCilPrinterClass} uses this information to prettify + * statement printing in certain special cases. *) + + method pExp: unit -> exp -> doc + (** Print expressions *) + + method pInit: unit -> init -> doc + (** Print initializers. This can be slow and is used by + * {!Cil.printGlobal} but not by {!Cil.dumpGlobal}. *) + + method dInit: out_channel -> int -> init -> unit + (** Dump a global to a file with a given indentation. This is used by + * {!Cil.dumpGlobal}. *) +end + + +class defaultCilPrinterClass : cilPrinter = object (self) + val mutable currentFormals : varinfo list = [] + method private getLastNamedArgument (s: string) : exp = + match List.rev currentFormals with + f :: _ -> Lval (var f) + | [] -> + E.s (warn "Cannot find the last named argument when priting call to %s\n" s) + + (*** VARIABLES ***) + (* variable use *) + method pVar (v:varinfo) = text v.vname + + (* variable declaration *) + method pVDecl () (v:varinfo) = + let stom, rest = separateStorageModifiers v.vattr in + (* First the storage modifiers *) + text (if v.vinline then "__inline " else "") + ++ d_storage () v.vstorage + ++ (self#pAttrs () stom) + ++ (self#pType (Some (text v.vname)) () v.vtype) + ++ text " " + ++ self#pAttrs () rest + + (*** L-VALUES ***) + method pLval () (lv:lval) = (* lval (base is 1st field) *) + match lv with + Var vi, o -> self#pOffset (self#pVar vi) o + | Mem e, Field(fi, o) -> + self#pOffset + ((self#pExpPrec arrowLevel () e) ++ text ("->" ^ fi.fname)) o + | Mem e, o -> + self#pOffset + (text "(*" ++ self#pExpPrec derefStarLevel () e ++ text ")") o + + (** Offsets **) + method pOffset (base: doc) = function + | NoOffset -> base + | Field (fi, o) -> + self#pOffset (base ++ text "." ++ text fi.fname) o + | Index (e, o) -> + self#pOffset (base ++ text "[" ++ self#pExp () e ++ text "]") o + + method private pLvalPrec (contextprec: int) () lv = + if getParenthLevel (Lval(lv)) >= contextprec then + text "(" ++ self#pLval () lv ++ text ")" + else + self#pLval () lv + + (*** EXPRESSIONS ***) + method pExp () (e: exp) : doc = + let level = getParenthLevel e in + match e with + Const(c) -> d_const () c + | Lval(l) -> self#pLval () l + | UnOp(u,e1,_) -> + (d_unop () u) ++ chr ' ' ++ (self#pExpPrec level () e1) + + | BinOp(b,e1,e2,_) -> + align + ++ (self#pExpPrec level () e1) + ++ chr ' ' + ++ (d_binop () b) + ++ chr ' ' + ++ (self#pExpPrec level () e2) + ++ unalign + + | CastE(t,e) -> + text "(" + ++ self#pType None () t + ++ text ")" + ++ self#pExpPrec level () e + + | SizeOf (t) -> + text "sizeof(" ++ self#pType None () t ++ chr ')' + | SizeOfE (e) -> + text "sizeof(" ++ self#pExp () e ++ chr ')' + + | SizeOfStr s -> + text "sizeof(" ++ d_const () (CStr s) ++ chr ')' + + | AlignOf (t) -> + text "__alignof__(" ++ self#pType None () t ++ chr ')' + | AlignOfE (e) -> + text "__alignof__(" ++ self#pExp () e ++ chr ')' + | AddrOf(lv) -> + text "& " ++ (self#pLvalPrec addrOfLevel () lv) + + | StartOf(lv) -> self#pLval () lv + + method private pExpPrec (contextprec: int) () (e: exp) = + let thisLevel = getParenthLevel e in + let needParens = + if thisLevel >= contextprec then + true + else if contextprec == bitwiseLevel then + (* quiet down some GCC warnings *) + thisLevel == additiveLevel || thisLevel == comparativeLevel + else + false + in + if needParens then + chr '(' ++ self#pExp () e ++ chr ')' + else + self#pExp () e + + method pInit () = function + SingleInit e -> self#pExp () e + | CompoundInit (t, initl) -> + (* We do not print the type of the Compound *) +(* + let dinit e = d_init () e in + dprintf "{@[%a@]}" + (docList ~sep:(chr ',' ++ break) dinit) initl +*) + let printDesignator = + if not !msvcMode then begin + (* Print only for union when we do not initialize the first field *) + match unrollType t, initl with + TComp(ci, _), [(Field(f, NoOffset), _)] -> + if not (ci.cstruct) && ci.cfields != [] && + (List.hd ci.cfields) != f then + true + else + false + | _ -> false + end else + false + in + let d_oneInit = function + Field(f, NoOffset), i -> + (if printDesignator then + text ("." ^ f.fname ^ " = ") + else nil) ++ self#pInit () i + | Index(e, NoOffset), i -> + (if printDesignator then + text "[" ++ self#pExp () e ++ text "] = " else nil) ++ + self#pInit () i + | _ -> E.s (unimp "Trying to print malformed initializer") + in + chr '{' ++ (align + ++ ((docList ~sep:(chr ',' ++ break) d_oneInit) () initl) + ++ unalign) + ++ chr '}' +(* + | ArrayInit (_, _, il) -> + chr '{' ++ (align + ++ ((docList (chr ',' ++ break) (self#pInit ())) () il) + ++ unalign) + ++ chr '}' +*) + (* dump initializers to a file. *) + method dInit (out: out_channel) (ind: int) (i: init) = + (* Dump an array *) + let dumpArray (bt: typ) (il: 'a list) (getelem: 'a -> init) = + let onALine = (* How many elements on a line *) + match unrollType bt with TComp _ | TArray _ -> 1 | _ -> 4 + in + let rec outputElements (isfirst: bool) (room_on_line: int) = function + [] -> output_string out "}" + | (i: 'a) :: rest -> + if not isfirst then output_string out ", "; + let new_room_on_line = + if room_on_line == 0 then begin + output_string out "\n"; output_string out (String.make ind ' '); + onALine - 1 + end else + room_on_line - 1 + in + self#dInit out (ind + 2) (getelem i); + outputElements false new_room_on_line rest + in + output_string out "{ "; + outputElements true onALine il + in + match i with + SingleInit e -> + fprint out !lineLength (indent ind (self#pExp () e)) + | CompoundInit (t, initl) -> begin + match unrollType t with + TArray(bt, _, _) -> + dumpArray bt initl (fun (_, i) -> i) + | _ -> + (* Now a structure or a union *) + fprint out !lineLength (indent ind (self#pInit () i)) + end +(* + | ArrayInit (bt, len, initl) -> begin + (* If the base type does not contain structs then use the pInit + match unrollType bt with + TComp _ | TArray _ -> + dumpArray bt initl (fun x -> x) + | _ -> *) + fprint out !lineLength (indent ind (self#pInit () i)) + end +*) + + (** What terminator to print after an instruction. sometimes we want to + * print sequences of instructions separated by comma *) + val mutable printInstrTerminator = ";" + + (*** INSTRUCTIONS ****) + method pInstr () (i:instr) = (* imperative instruction *) + match i with + | Set(lv,e,l) -> begin + (* Be nice to some special cases *) + match e with + BinOp((PlusA|PlusPI|IndexPI),Lval(lv'), Const(CInt64(one,_,_)),_) + when Util.equals lv lv' && one = Int64.one && not !printCilAsIs -> + self#pLineDirective l + ++ self#pLval () lv + ++ text (" ++" ^ printInstrTerminator) + + | BinOp((MinusA|MinusPI),Lval(lv'), + Const(CInt64(one,_,_)), _) + when Util.equals lv lv' && one = Int64.one && not !printCilAsIs -> + self#pLineDirective l + ++ self#pLval () lv + ++ text (" --" ^ printInstrTerminator) + + | BinOp((PlusA|PlusPI|IndexPI),Lval(lv'),Const(CInt64(mone,_,_)),_) + when Util.equals lv lv' && mone = Int64.minus_one + && not !printCilAsIs -> + self#pLineDirective l + ++ self#pLval () lv + ++ text (" --" ^ printInstrTerminator) + + | BinOp((PlusA|PlusPI|IndexPI|MinusA|MinusPP|MinusPI|BAnd|BOr|BXor| + Mult|Div|Mod|Shiftlt|Shiftrt) as bop, + Lval(lv'),e,_) when Util.equals lv lv' -> + self#pLineDirective l + ++ self#pLval () lv + ++ text " " ++ d_binop () bop + ++ text "= " + ++ self#pExp () e + ++ text printInstrTerminator + + | _ -> + self#pLineDirective l + ++ self#pLval () lv + ++ text " = " + ++ self#pExp () e + ++ text printInstrTerminator + + end + (* In cabs2cil we have turned the call to builtin_va_arg into a + * three-argument call: the last argument is the address of the + * destination *) + | Call(None, Lval(Var vi, NoOffset), [dest; SizeOf t; adest], l) + when vi.vname = "__builtin_va_arg" && not !printCilAsIs -> + let destlv = match stripCasts adest with + AddrOf destlv -> destlv + | _ -> E.s (E.error "Encountered unexpected call to %s\n" vi.vname) + in + self#pLineDirective l + ++ self#pLval () destlv ++ text " = " + + (* Now the function name *) + ++ text "__builtin_va_arg" + ++ text "(" ++ (align + (* Now the arguments *) + ++ self#pExp () dest + ++ chr ',' ++ break + ++ self#pType None () t + ++ unalign) + ++ text (")" ^ printInstrTerminator) + + (* In cabs2cil we have dropped the last argument in the call to + * __builtin_stdarg_start. *) + | Call(None, Lval(Var vi, NoOffset), [marker], l) + when vi.vname = "__builtin_stdarg_start" && not !printCilAsIs -> begin + let last = self#getLastNamedArgument vi.vname in + self#pInstr () (Call(None,Lval(Var vi,NoOffset),[marker; last],l)) + end + + (* In cabs2cil we have dropped the last argument in the call to + * __builtin_next_arg. *) + | Call(res, Lval(Var vi, NoOffset), [ ], l) + when vi.vname = "__builtin_next_arg" && not !printCilAsIs -> begin + let last = self#getLastNamedArgument vi.vname in + self#pInstr () (Call(res,Lval(Var vi,NoOffset),[last],l)) + end + + (* In cparser we have turned the call to + * __builtin_types_compatible_p(t1, t2) into + * __builtin_types_compatible_p(sizeof t1, sizeof t2), so that we can + * represent the types as expressions. + * Remove the sizeofs when printing. *) + | Call(dest, Lval(Var vi, NoOffset), [SizeOf t1; SizeOf t2], l) + when vi.vname = "__builtin_types_compatible_p" && not !printCilAsIs -> + self#pLineDirective l + (* Print the destination *) + ++ (match dest with + None -> nil + | Some lv -> self#pLval () lv ++ text " = ") + (* Now the call itself *) + ++ dprintf "%s(%a, %a)" vi.vname + (self#pType None) t1 (self#pType None) t2 + ++ text printInstrTerminator + | Call(_, Lval(Var vi, NoOffset), _, l) + when vi.vname = "__builtin_types_compatible_p" && not !printCilAsIs -> + E.s (bug "__builtin_types_compatible_p: cabs2cil should have added sizeof to the arguments.") + + | Call(dest,e,args,l) -> + self#pLineDirective l + ++ (match dest with + None -> nil + | Some lv -> + self#pLval () lv ++ text " = " ++ + (* Maybe we need to print a cast *) + (let destt = typeOfLval lv in + match unrollType (typeOf e) with + TFun (rt, _, _, _) + when not (Util.equals (!pTypeSig rt) + (!pTypeSig destt)) -> + text "(" ++ self#pType None () destt ++ text ")" + | _ -> nil)) + (* Now the function name *) + ++ (let ed = self#pExp () e in + match e with + Lval(Var _, _) -> ed + | _ -> text "(" ++ ed ++ text ")") + ++ text "(" ++ + (align + (* Now the arguments *) + ++ (docList ~sep:(chr ',' ++ break) + (self#pExp ()) () args) + ++ unalign) + ++ text (")" ^ printInstrTerminator) + + | Asm(attrs, tmpls, outs, ins, clobs, l) -> + if !msvcMode then + self#pLineDirective l + ++ text "__asm {" + ++ (align + ++ (docList ~sep:line text () tmpls) + ++ unalign) + ++ text ("}" ^ printInstrTerminator) + else + self#pLineDirective l + ++ text ("__asm__ ") + ++ self#pAttrs () attrs + ++ text " (" + ++ (align + ++ (docList ~sep:line + (fun x -> text ("\"" ^ escape_string x ^ "\"")) + () tmpls) + ++ + (if outs = [] && ins = [] && clobs = [] then + chr ':' + else + (text ": " + ++ (docList ~sep:(chr ',' ++ break) + (fun (c, lv) -> + text ("\"" ^ escape_string c ^ "\" (") + ++ self#pLval () lv + ++ text ")") () outs))) + ++ + (if ins = [] && clobs = [] then + nil + else + (text ": " + ++ (docList ~sep:(chr ',' ++ break) + (fun (c, e) -> + text ("\"" ^ escape_string c ^ "\" (") + ++ self#pExp () e + ++ text ")") () ins))) + ++ + (if clobs = [] then nil + else + (text ": " + ++ (docList ~sep:(chr ',' ++ break) + (fun c -> text ("\"" ^ escape_string c ^ "\"")) + () + clobs))) + ++ unalign) + ++ text (")" ^ printInstrTerminator) + + + (**** STATEMENTS ****) + method pStmt () (s:stmt) = (* control-flow statement *) + self#pStmtNext invalidStmt () s + + method dStmt (out: out_channel) (ind: int) (s:stmt) : unit = + fprint out !lineLength (indent ind (self#pStmt () s)) + + method dBlock (out: out_channel) (ind: int) (b:block) : unit = + fprint out !lineLength (indent ind (align ++ self#pBlock () b)) + + method private pStmtNext (next: stmt) () (s: stmt) = + (* print the labels *) + ((docList ~sep:line (fun l -> self#pLabel () l)) () s.labels) + (* print the statement itself. If the labels are non-empty and the + * statement is empty, print a semicolon *) + ++ + (if s.skind = Instr [] && s.labels <> [] then + text ";" + else + (if s.labels <> [] then line else nil) + ++ self#pStmtKind next () s.skind) + + method private pLabel () = function + Label (s, _, true) -> text (s ^ ": ") + | Label (s, _, false) -> text (s ^ ": /* CIL Label */ ") + | Case (e, _) -> text "case " ++ self#pExp () e ++ text ": " + | Default _ -> text "default: " + + (* The pBlock will put the unalign itself *) + method pBlock () (blk: block) = + let rec dofirst () = function + [] -> nil + | [x] -> self#pStmtNext invalidStmt () x + | x :: rest -> dorest nil x rest + and dorest acc prev = function + [] -> acc ++ (self#pStmtNext invalidStmt () prev) + | x :: rest -> + dorest (acc ++ (self#pStmtNext x () prev) ++ line) + x rest + in + (* Let the host of the block decide on the alignment. The d_block will + * pop the alignment as well *) + text "{" + ++ + (if blk.battrs <> [] then + self#pAttrsGen true blk.battrs + else nil) + ++ line + ++ (dofirst () blk.bstmts) + ++ unalign ++ line ++ text "}" + + + (* Store here the name of the last file printed in a line number. This is + * private to the object *) + val mutable lastFileName = "" + (* Make sure that you only call self#pLineDirective on an empty line *) + method pLineDirective ?(forcefile=false) l = + currentLoc := l; + match !lineDirectiveStyle with + | Some style when l.line > 0 -> + let directive = + match style with + | LineComment -> text "//#line " + | LinePreprocessorOutput when not !msvcMode -> chr '#' + | _ -> text "#line" + in + let filename = + if forcefile || l.file <> lastFileName then + begin + lastFileName <- l.file; + text " \"" ++ text l.file ++ text "\"" + end + else + nil + in + leftflush ++ directive ++ chr ' ' ++ num l.line ++ filename ++ line + | _ -> + nil + + + method private pStmtKind (next: stmt) () = function + Return(None, l) -> + self#pLineDirective l + ++ text "return;" + + | Return(Some e, l) -> + self#pLineDirective l + ++ text "return (" + ++ self#pExp () e + ++ text ");" + + | Goto (sref, l) -> begin + (* Grab one of the labels *) + let rec pickLabel = function + [] -> None + | Label (l, _, _) :: _ -> Some l + | _ :: rest -> pickLabel rest + in + match pickLabel !sref.labels with + Some l -> text ("goto " ^ l ^ ";") + | None -> + ignore (error "Cannot find label for target of goto\n"); + text "goto __invalid_label;" + end + + | Break l -> + self#pLineDirective l + ++ text "break;" + + | Continue l -> + self#pLineDirective l + ++ text "continue;" + + | Instr il -> + align + ++ (docList ~sep:line (fun i -> self#pInstr () i) () il) + ++ unalign + + | If(be,t,{bstmts=[];battrs=[]},l) when not !printCilAsIs -> + self#pLineDirective l + ++ text "if" + ++ (align + ++ text " (" + ++ self#pExp () be + ++ text ") " + ++ self#pBlock () t) + + | If(be,t,{bstmts=[{skind=Goto(gref,_);labels=[]}]; + battrs=[]},l) + when !gref == next && not !printCilAsIs -> + self#pLineDirective l + ++ text "if" + ++ (align + ++ text " (" + ++ self#pExp () be + ++ text ") " + ++ self#pBlock () t) + + | If(be,{bstmts=[];battrs=[]},e,l) when not !printCilAsIs -> + self#pLineDirective l + ++ text "if" + ++ (align + ++ text " (" + ++ self#pExp () (UnOp(LNot,be,intType)) + ++ text ") " + ++ self#pBlock () e) + + | If(be,{bstmts=[{skind=Goto(gref,_);labels=[]}]; + battrs=[]},e,l) + when !gref == next && not !printCilAsIs -> + self#pLineDirective l + ++ text "if" + ++ (align + ++ text " (" + ++ self#pExp () (UnOp(LNot,be,intType)) + ++ text ") " + ++ self#pBlock () e) + + | If(be,t,e,l) -> + self#pLineDirective l + ++ (align + ++ text "if" + ++ (align + ++ text " (" + ++ self#pExp () be + ++ text ") " + ++ self#pBlock () t) + ++ text " " (* sm: indent next code 2 spaces (was 4) *) + ++ (align + ++ text "else " + ++ self#pBlock () e) + ++ unalign) + + | Switch(e,b,_,l) -> + self#pLineDirective l + ++ (align + ++ text "switch (" + ++ self#pExp () e + ++ text ") " + ++ self#pBlock () b) + +(* + | Loop(b, l, _, _) -> begin + (* Maybe the first thing is a conditional. Turn it into a WHILE *) + try + let term, bodystmts = + let rec skipEmpty = function + [] -> [] + | {skind=Instr [];labels=[]} :: rest -> skipEmpty rest + | x -> x + in + (* Bill McCloskey: Do not remove the If if it has labels *) + match skipEmpty b.bstmts with + {skind=If(e,tb,fb,_); labels=[]} :: rest + when not !printCilAsIs -> begin + match skipEmpty tb.bstmts, skipEmpty fb.bstmts with + [], {skind=Break _; labels=[]} :: _ -> e, rest + | {skind=Break _; labels=[]} :: _, [] + -> UnOp(LNot, e, intType), rest + | _ -> raise Not_found + end + | _ -> raise Not_found + in + self#pLineDirective l + ++ text "wh" + ++ (align + ++ text "ile (" + ++ self#pExp () term + ++ text ") " + ++ self#pBlock () {bstmts=bodystmts; battrs=b.battrs}) + + with Not_found -> + self#pLineDirective l + ++ text "wh" + ++ (align + ++ text "ile (1) " + ++ self#pBlock () b) + end +*) + + | While (e, b, l) -> + self#pLineDirective l + ++ (align + ++ text "while (" + ++ self#pExp () e + ++ text ") " + ++ self#pBlock () b) + + | DoWhile (e, b, l) -> + self#pLineDirective l + ++ (align + ++ text "do " + ++ self#pBlock () b + ++ text " while (" + ++ self#pExp () e + ++ text ");") + + | For (bInit, e, bIter, b, l) -> + ignore (E.warn + "in for loops, the 1st and 3rd expressions are not printed"); + self#pLineDirective l + ++ (align + ++ text "for (" + ++ text "/* ??? */" (* self#pBlock () bInit *) + ++ text "; " + ++ self#pExp () e + ++ text "; " + ++ text "/* ??? */" (* self#pBlock() bIter *) + ++ text ") " + ++ self#pBlock () b) + + | Block b -> align ++ self#pBlock () b + + | TryFinally (b, h, l) -> + self#pLineDirective l + ++ text "__try " + ++ align + ++ self#pBlock () b + ++ text " __fin" ++ align ++ text "ally " + ++ self#pBlock () h + + | TryExcept (b, (il, e), h, l) -> + self#pLineDirective l + ++ text "__try " + ++ align + ++ self#pBlock () b + ++ text " __e" ++ align ++ text "xcept(" ++ line + ++ align + (* Print the instructions but with a comma at the end, instead of + * semicolon *) + ++ (printInstrTerminator <- ","; + let res = + (docList ~sep:line (self#pInstr ()) + () il) + in + printInstrTerminator <- ";"; + res) + ++ self#pExp () e + ++ text ") " ++ unalign + ++ self#pBlock () h + + + (*** GLOBALS ***) + method pGlobal () (g:global) : doc = (* global (vars, types, etc.) *) + match g with + | GFun (fundec, l) -> + (* If the function has attributes then print a prototype because + * GCC cannot accept function attributes in a definition *) + let oldattr = fundec.svar.vattr in + (* Always pring the file name before function declarations *) + let proto = + if oldattr <> [] then + (self#pLineDirective l) ++ (self#pVDecl () fundec.svar) + ++ chr ';' ++ line + else nil in + (* Temporarily remove the function attributes *) + fundec.svar.vattr <- []; + let body = (self#pLineDirective ~forcefile:true l) + ++ (self#pFunDecl () fundec) in + fundec.svar.vattr <- oldattr; + proto ++ body ++ line + + | GType (typ, l) -> + self#pLineDirective ~forcefile:true l ++ + text "typedef " + ++ (self#pType (Some (text typ.tname)) () typ.ttype) + ++ text ";\n" + + | GEnumTag (enum, l) -> + self#pLineDirective l ++ + text "enum" ++ align ++ text (" " ^ enum.ename) ++ + text " {" ++ line + ++ (docList ~sep:(chr ',' ++ line) + (fun (n,i, loc) -> + text (n ^ " = ") + ++ self#pExp () i) + () enum.eitems) + ++ unalign ++ line ++ text "} " + ++ self#pAttrs () enum.eattr ++ text";\n" + + | GEnumTagDecl (enum, l) -> (* This is a declaration of a tag *) + self#pLineDirective l ++ + text ("enum " ^ enum.ename ^ ";\n") + + | GCompTag (comp, l) -> (* This is a definition of a tag *) + let n = comp.cname in + let su, su1, su2 = + if comp.cstruct then "struct", "str", "uct" + else "union", "uni", "on" + in + let sto_mod, rest_attr = separateStorageModifiers comp.cattr in + self#pLineDirective ~forcefile:true l ++ + text su1 ++ (align ++ text su2 ++ chr ' ' ++ (self#pAttrs () sto_mod) + ++ text n + ++ text " {" ++ line + ++ ((docList ~sep:line (self#pFieldDecl ())) () + comp.cfields) + ++ unalign) + ++ line ++ text "}" ++ + (self#pAttrs () rest_attr) ++ text ";\n" + + | GCompTagDecl (comp, l) -> (* This is a declaration of a tag *) + self#pLineDirective l ++ + text (compFullName comp) ++ text ";\n" + + | GVar (vi, io, l) -> + self#pLineDirective ~forcefile:true l ++ + self#pVDecl () vi + ++ chr ' ' + ++ (match io.init with + None -> nil + | Some i -> text " = " ++ + (let islong = + match i with + CompoundInit (_, il) when List.length il >= 8 -> true + | _ -> false + in + if islong then + line ++ self#pLineDirective l ++ text " " + else nil) ++ + (self#pInit () i)) + ++ text ";\n" + + (* print global variable 'extern' declarations, and function prototypes *) + | GVarDecl (vi, l) -> + self#pLineDirective l ++ + (self#pVDecl () vi) + ++ text ";\n" + + | GAsm (s, l) -> + self#pLineDirective l ++ + text ("__asm__(\"" ^ escape_string s ^ "\");\n") + + | GPragma (Attr(an, args), l) -> + (* sm: suppress printing pragmas that gcc does not understand *) + (* assume anything starting with "ccured" is ours *) + (* also don't print the 'combiner' pragma *) + (* nor 'cilnoremove' *) + let suppress = + not !print_CIL_Input && + not !msvcMode && + ((startsWith "box" an) || + (startsWith "ccured" an) || + (an = "merger") || + (an = "cilnoremove")) in + let d = + match an, args with + | _, [] -> + text an + | "weak", [ACons (symbol, [])] -> + text "weak " ++ text symbol + | _ -> + text (an ^ "(") + ++ docList ~sep:(chr ',') (self#pAttrParam ()) () args + ++ text ")" + in + self#pLineDirective l + ++ (if suppress then text "/* " else text "") + ++ (text "#pragma ") + ++ d + ++ (if suppress then text " */\n" else text "\n") + + | GText s -> + if s <> "//" then + text s ++ text "\n" + else + nil + + + method dGlobal (out: out_channel) (g: global) : unit = + (* For all except functions and variable with initializers, use the + * pGlobal *) + match g with + GFun (fdec, l) -> + (* If the function has attributes then print a prototype because + * GCC cannot accept function attributes in a definition *) + let oldattr = fdec.svar.vattr in + let proto = + if oldattr <> [] then + (self#pLineDirective l) ++ (self#pVDecl () fdec.svar) + ++ chr ';' ++ line + else nil in + fprint out !lineLength + (proto ++ (self#pLineDirective ~forcefile:true l)); + (* Temporarily remove the function attributes *) + fdec.svar.vattr <- []; + fprint out !lineLength (self#pFunDecl () fdec); + fdec.svar.vattr <- oldattr; + output_string out "\n" + + | GVar (vi, {init = Some i}, l) -> begin + fprint out !lineLength + (self#pLineDirective ~forcefile:true l ++ + self#pVDecl () vi + ++ text " = " + ++ (let islong = + match i with + CompoundInit (_, il) when List.length il >= 8 -> true + | _ -> false + in + if islong then + line ++ self#pLineDirective l ++ text " " + else nil)); + self#dInit out 3 i; + output_string out ";\n" + end + + | g -> fprint out !lineLength (self#pGlobal () g) + + method pFieldDecl () fi = + (self#pType + (Some (text (if fi.fname = missingFieldName then "" else fi.fname))) + () + fi.ftype) + ++ text " " + ++ (match fi.fbitfield with None -> nil + | Some i -> text ": " ++ num i ++ text " ") + ++ self#pAttrs () fi.fattr + ++ text ";" + + method private pFunDecl () f = + self#pVDecl () f.svar + ++ line + ++ text "{ " + ++ (align + (* locals. *) + ++ (docList ~sep:line (fun vi -> self#pVDecl () vi ++ text ";") + () f.slocals) + ++ line ++ line + (* the body *) + ++ ((* remember the declaration *) currentFormals <- f.sformals; + let body = self#pBlock () f.sbody in + currentFormals <- []; + body)) + ++ line + ++ text "}" + + (***** PRINTING DECLARATIONS and TYPES ****) + + method pType (nameOpt: doc option) (* Whether we are declaring a name or + * we are just printing a type *) + () (t:typ) = (* use of some type *) + let name = match nameOpt with None -> nil | Some d -> d in + let printAttributes (a: attributes) = + let pa = self#pAttrs () a in + match nameOpt with + | None when not !print_CIL_Input && not !msvcMode -> + (* Cannot print the attributes in this case because gcc does not + * like them here, except if we are printing for CIL, or for MSVC. + * In fact, for MSVC we MUST print attributes such as __stdcall *) + if pa = nil then nil else + text "/*" ++ pa ++ text "*/" + | _ -> pa + in + match t with + TVoid a -> + text "void" + ++ self#pAttrs () a + ++ text " " + ++ name + + | TInt (ikind,a) -> + d_ikind () ikind + ++ self#pAttrs () a + ++ text " " + ++ name + + | TFloat(fkind, a) -> + d_fkind () fkind + ++ self#pAttrs () a + ++ text " " + ++ name + + | TComp (comp, a) -> (* A reference to a struct *) + let su = if comp.cstruct then "struct" else "union" in + text (su ^ " " ^ comp.cname ^ " ") + ++ self#pAttrs () a + ++ name + + | TEnum (enum, a) -> + text ("enum " ^ enum.ename ^ " ") + ++ self#pAttrs () a + ++ name + | TPtr (bt, a) -> + (* Parenthesize the ( * attr name) if a pointer to a function or an + * array. However, on MSVC the __stdcall modifier must appear right + * before the pointer constructor "(__stdcall *f)". We push them into + * the parenthesis. *) + let (paren: doc option), (bt': typ) = + match bt with + TFun(rt, args, isva, fa) when !msvcMode -> + let an, af', at = partitionAttributes ~default:AttrType fa in + (* We take the af' and we put them into the parentheses *) + Some (text "(" ++ printAttributes af'), + TFun(rt, args, isva, addAttributes an at) + + | TFun _ | TArray _ -> Some (text "("), bt + + | _ -> None, bt + in + let name' = text "*" ++ printAttributes a ++ name in + let name'' = (* Put the parenthesis *) + match paren with + Some p -> p ++ name' ++ text ")" + | _ -> name' + in + self#pType + (Some name'') + () + bt' + + | TArray (elemt, lo, a) -> + (* ignore the const attribute for arrays *) + let a' = dropAttributes [ "const" ] a in + let name' = + if a' == [] then name else + if nameOpt == None then printAttributes a' else + text "(" ++ printAttributes a' ++ name ++ text ")" + in + self#pType + (Some (name' + ++ text "[" + ++ (match lo with None -> nil | Some e -> self#pExp () e) + ++ text "]")) + () + elemt + + | TFun (restyp, args, isvararg, a) -> + let name' = + if a == [] then name else + if nameOpt == None then printAttributes a else + text "(" ++ printAttributes a ++ name ++ text ")" + in + self#pType + (Some + (name' + ++ text "(" + ++ (align + ++ + (if args = Some [] && isvararg then + text "..." + else + (if args = None then nil + else if args = Some [] then text "void" + else + let pArg (aname, atype, aattr) = + let stom, rest = separateStorageModifiers aattr in + (* First the storage modifiers *) + (self#pAttrs () stom) + ++ (self#pType (Some (text aname)) () atype) + ++ text " " + ++ self#pAttrs () rest + in + (docList ~sep:(chr ',' ++ break) pArg) () + (argsToList args)) + ++ (if isvararg then break ++ text ", ..." else nil)) + ++ unalign) + ++ text ")")) + () + restyp + + | TNamed (t, a) -> + text t.tname ++ self#pAttrs () a ++ text " " ++ name + + | TBuiltin_va_list a -> + text "__builtin_va_list" + ++ self#pAttrs () a + ++ text " " + ++ name + + + (**** PRINTING ATTRIBUTES *********) + method pAttrs () (a: attributes) = + self#pAttrsGen false a + + + (* Print one attribute. Return also an indication whether this attribute + * should be printed inside the __attribute__ list *) + method pAttr (Attr(an, args): attribute) : doc * bool = + (* Recognize and take care of some known cases *) + match an, args with + "const", [] -> text "const", false + (* Put the aconst inside the attribute list *) + | "aconst", [] when not !msvcMode -> text "__const__", true + | "thread", [] when not !msvcMode -> text "__thread", false +(* + | "used", [] when not !msvcMode -> text "__attribute_used__", false +*) + | "volatile", [] -> text "volatile", false + | "restrict", [] -> text "__restrict", false + | "missingproto", [] -> text "/* missing proto */", false + | "cdecl", [] when !msvcMode -> text "__cdecl", false + | "stdcall", [] when !msvcMode -> text "__stdcall", false + | "fastcall", [] when !msvcMode -> text "__fastcall", false + | "declspec", args when !msvcMode -> + text "__declspec(" + ++ docList (self#pAttrParam ()) () args + ++ text ")", false + | "w64", [] when !msvcMode -> text "__w64", false + | "asm", args -> + text "__asm__(" + ++ docList (self#pAttrParam ()) () args + ++ text ")", false + (* we suppress printing mode(__si__) because it triggers an *) + (* internal compiler error in all current gcc versions *) + (* sm: I've now encountered a problem with mode(__hi__)... *) + (* I don't know what's going on, but let's try disabling all "mode"..*) + | "mode", [ACons(tag,[])] -> + text "/* mode(" ++ text tag ++ text ") */", false + + (* sm: also suppress "format" because we seem to print it in *) + (* a way gcc does not like *) + | "format", _ -> text "/* format attribute */", false + + (* sm: here's another one I don't want to see gcc warnings about.. *) + | "mayPointToStack", _ when not !print_CIL_Input + (* [matth: may be inside another comment.] + -> text "/*mayPointToStack*/", false + *) + -> text "", false + + | _ -> (* This is the dafault case *) + (* Add underscores to the name *) + let an' = if !msvcMode then "__" ^ an else "__" ^ an ^ "__" in + if args = [] then + text an', true + else + text (an' ^ "(") + ++ (docList (self#pAttrParam ()) () args) + ++ text ")", + true + + method pAttrParam () = function + | AInt n -> num n + | AStr s -> text ("\"" ^ escape_string s ^ "\"") + | ACons(s, []) -> text s + | ACons(s,al) -> + text (s ^ "(") + ++ (docList (self#pAttrParam ()) () al) + ++ text ")" + | ASizeOfE a -> text "sizeof(" ++ self#pAttrParam () a ++ text ")" + | ASizeOf t -> text "sizeof(" ++ self#pType None () t ++ text ")" + | ASizeOfS ts -> text "sizeof()" + | AAlignOfE a -> text "__alignof__(" ++ self#pAttrParam () a ++ text ")" + | AAlignOf t -> text "__alignof__(" ++ self#pType None () t ++ text ")" + | AAlignOfS ts -> text "__alignof__()" + | AUnOp(u,a1) -> + (d_unop () u) ++ text " (" ++ (self#pAttrParam () a1) ++ text ")" + + | ABinOp(b,a1,a2) -> + align + ++ text "(" + ++ (self#pAttrParam () a1) + ++ text ") " + ++ (d_binop () b) + ++ break + ++ text " (" ++ (self#pAttrParam () a2) ++ text ") " + ++ unalign + | ADot (ap, s) -> (self#pAttrParam () ap) ++ text ("." ^ s) + + (* A general way of printing lists of attributes *) + method private pAttrsGen (block: bool) (a: attributes) = + (* Scan all the attributes and separate those that must be printed inside + * the __attribute__ list *) + let rec loop (in__attr__: doc list) = function + [] -> begin + match in__attr__ with + [] -> nil + | _ :: _-> + (* sm: added 'forgcc' calls to not comment things out + * if CIL is the consumer; this is to address a case + * Daniel ran into where blockattribute(nobox) was being + * dropped by the merger + *) + (if block then + text (" " ^ (forgcc "/*") ^ " __blockattribute__(") + else + text "__attribute__((") + + ++ (docList ~sep:(chr ',' ++ break) + (fun a -> a)) () in__attr__ + ++ text ")" + ++ (if block then text (forgcc "*/") else text ")") + end + | x :: rest -> + let dx, ina = self#pAttr x in + if ina then + loop (dx :: in__attr__) rest + else + dx ++ text " " ++ loop in__attr__ rest + in + let res = loop [] a in + if res = nil then + res + else + text " " ++ res ++ text " " + +end (* class defaultCilPrinterClass *) + +let defaultCilPrinter = new defaultCilPrinterClass + +(* Top-level printing functions *) +let printType (pp: cilPrinter) () (t: typ) : doc = + pp#pType None () t + +let printExp (pp: cilPrinter) () (e: exp) : doc = + pp#pExp () e + +let printLval (pp: cilPrinter) () (lv: lval) : doc = + pp#pLval () lv + +let printGlobal (pp: cilPrinter) () (g: global) : doc = + pp#pGlobal () g + +let dumpGlobal (pp: cilPrinter) (out: out_channel) (g: global) : unit = + pp#dGlobal out g + +let printAttr (pp: cilPrinter) () (a: attribute) : doc = + let ad, _ = pp#pAttr a in ad + +let printAttrs (pp: cilPrinter) () (a: attributes) : doc = + pp#pAttrs () a + +let printInstr (pp: cilPrinter) () (i: instr) : doc = + pp#pInstr () i + +let printStmt (pp: cilPrinter) () (s: stmt) : doc = + pp#pStmt () s + +let printBlock (pp: cilPrinter) () (b: block) : doc = + (* We must add the alignment ourselves, beucase pBlock will pop it *) + align ++ pp#pBlock () b + +let dumpStmt (pp: cilPrinter) (out: out_channel) (ind: int) (s: stmt) : unit = + pp#dStmt out ind s + +let dumpBlock (pp: cilPrinter) (out: out_channel) (ind: int) (b: block) : unit = + pp#dBlock out ind b + +let printInit (pp: cilPrinter) () (i: init) : doc = + pp#pInit () i + +let dumpInit (pp: cilPrinter) (out: out_channel) (ind: int) (i: init) : unit = + pp#dInit out ind i + +(* Now define some short cuts *) +let d_exp () e = printExp defaultCilPrinter () e +let _ = pd_exp := d_exp +let d_lval () lv = printLval defaultCilPrinter () lv +let d_offset base () off = defaultCilPrinter#pOffset base off +let d_init () i = printInit defaultCilPrinter () i +let d_type () t = printType defaultCilPrinter () t +let d_global () g = printGlobal defaultCilPrinter () g +let d_attrlist () a = printAttrs defaultCilPrinter () a +let d_attr () a = printAttr defaultCilPrinter () a +let d_attrparam () e = defaultCilPrinter#pAttrParam () e +let d_label () l = defaultCilPrinter#pLabel () l +let d_stmt () s = printStmt defaultCilPrinter () s +let d_block () b = printBlock defaultCilPrinter () b +let d_instr () i = printInstr defaultCilPrinter () i + +let d_shortglobal () = function + GPragma (Attr(an, _), _) -> dprintf "#pragma %s" an + | GType (ti, _) -> dprintf "typedef %s" ti.tname + | GVarDecl (vi, _) -> dprintf "declaration of %s" vi.vname + | GVar (vi, _, _) -> dprintf "definition of %s" vi.vname + | GCompTag(ci,_) -> dprintf "definition of %s" (compFullName ci) + | GCompTagDecl(ci,_) -> dprintf "declaration of %s" (compFullName ci) + | GEnumTag(ei,_) -> dprintf "definition of enum %s" ei.ename + | GEnumTagDecl(ei,_) -> dprintf "declaration of enum %s" ei.ename + | GFun(fd, _) -> dprintf "definition of %s" fd.svar.vname + | GText _ -> text "GText" + | GAsm _ -> text "GAsm" + + +(* sm: given an ordinary CIL object printer, yield one which + * behaves the same, except it never prints #line directives + * (this is useful for debugging printfs) *) +let dn_obj (func: unit -> 'a -> doc) : (unit -> 'a -> doc) = +begin + (* construct the closure to return *) + let theFunc () (obj:'a) : doc = + begin + let prevStyle = !lineDirectiveStyle in + lineDirectiveStyle := None; + let ret = (func () obj) in (* call underlying printer *) + lineDirectiveStyle := prevStyle; + ret + end in + theFunc +end + +(* now define shortcuts for the non-location-printing versions, + * with the naming prefix "dn_" *) +let dn_exp = (dn_obj d_exp) +let dn_lval = (dn_obj d_lval) +(* dn_offset is missing because it has a different interface *) +let dn_init = (dn_obj d_init) +let dn_type = (dn_obj d_type) +let dn_global = (dn_obj d_global) +let dn_attrlist = (dn_obj d_attrlist) +let dn_attr = (dn_obj d_attr) +let dn_attrparam = (dn_obj d_attrparam) +let dn_stmt = (dn_obj d_stmt) +let dn_instr = (dn_obj d_instr) + + +(* Now define a cilPlainPrinter *) +class plainCilPrinterClass = + (* We keep track of the composite types that we have done to avoid + * recursion *) + let donecomps : (int, unit) H.t = H.create 13 in + object (self) + + inherit defaultCilPrinterClass as super + + (*** PLAIN TYPES ***) + method pType (dn: doc option) () (t: typ) = + match dn with + None -> self#pOnlyType () t + | Some d -> d ++ text " : " ++ self#pOnlyType () t + + method private pOnlyType () = function + TVoid a -> dprintf "TVoid(@[%a@])" self#pAttrs a + | TInt(ikind, a) -> dprintf "TInt(@[%a,@?%a@])" + d_ikind ikind self#pAttrs a + | TFloat(fkind, a) -> + dprintf "TFloat(@[%a,@?%a@])" d_fkind fkind self#pAttrs a + | TNamed (t, a) -> + dprintf "TNamed(@[%s,@?%a,@?%a@])" + t.tname self#pOnlyType t.ttype self#pAttrs a + | TPtr(t, a) -> dprintf "TPtr(@[%a,@?%a@])" self#pOnlyType t self#pAttrs a + | TArray(t,l,a) -> + let dl = match l with + None -> text "None" | Some l -> dprintf "Some(@[%a@])" self#pExp l in + dprintf "TArray(@[%a,@?%a,@?%a@])" + self#pOnlyType t insert dl self#pAttrs a + | TEnum(enum,a) -> dprintf "Enum(%s,@[%a@])" enum.ename self#pAttrs a + | TFun(tr,args,isva,a) -> + dprintf "TFun(@[%a,@?%a%s,@?%a@])" + self#pOnlyType tr + insert + (if args = None then text "None" + else (docList ~sep:(chr ',' ++ break) + (fun (an,at,aa) -> + dprintf "%s: %a" an self#pOnlyType at)) + () + (argsToList args)) + (if isva then "..." else "") self#pAttrs a + | TComp (comp, a) -> + if H.mem donecomps comp.ckey then + dprintf "TCompLoop(%s %s, _, %a)" + (if comp.cstruct then "struct" else "union") comp.cname + self#pAttrs comp.cattr + else begin + H.add donecomps comp.ckey (); (* Add it before we do the fields *) + dprintf "TComp(@[%s %s,@?%a,@?%a,@?%a@])" + (if comp.cstruct then "struct" else "union") comp.cname + (docList ~sep:(chr ',' ++ break) + (fun f -> dprintf "%s : %a" f.fname self#pOnlyType f.ftype)) + comp.cfields + self#pAttrs comp.cattr + self#pAttrs a + end + | TBuiltin_va_list a -> + dprintf "TBuiltin_va_list(%a)" self#pAttrs a + + + (* Some plain pretty-printers. Unlike the above these expose all the + * details of the internal representation *) + method pExp () = function + Const(c) -> + let d_plainconst () c = + match c with + CInt64(i, ik, so) -> + dprintf "Int64(%s,%a,%s)" + (Int64.format "%d" i) + d_ikind ik + (match so with Some s -> s | _ -> "None") + | CStr(s) -> + text ("CStr(\"" ^ escape_string s ^ "\")") + | CWStr(s) -> + dprintf "CWStr(%a)" d_const c + + | CChr(c) -> text ("CChr('" ^ escape_char c ^ "')") + | CReal(f, fk, so) -> + dprintf "CReal(%f, %a, %s)" + f + d_fkind fk + (match so with Some s -> s | _ -> "None") + | CEnum(_, s, _) -> text s + in + text "Const(" ++ d_plainconst () c ++ text ")" + + + | Lval(lv) -> + text "Lval(" + ++ (align + ++ self#pLval () lv + ++ unalign) + ++ text ")" + + | CastE(t,e) -> dprintf "CastE(@[%a,@?%a@])" self#pOnlyType t self#pExp e + + | UnOp(u,e1,_) -> + dprintf "UnOp(@[%a,@?%a@])" + d_unop u self#pExp e1 + + | BinOp(b,e1,e2,_) -> + let d_plainbinop () b = + match b with + PlusA -> text "PlusA" + | PlusPI -> text "PlusPI" + | IndexPI -> text "IndexPI" + | MinusA -> text "MinusA" + | MinusPP -> text "MinusPP" + | MinusPI -> text "MinusPI" + | _ -> d_binop () b + in + dprintf "%a(@[%a,@?%a@])" d_plainbinop b + self#pExp e1 self#pExp e2 + + | SizeOf (t) -> + text "sizeof(" ++ self#pType None () t ++ chr ')' + | SizeOfE (e) -> + text "sizeofE(" ++ self#pExp () e ++ chr ')' + | SizeOfStr (s) -> + text "sizeofStr(" ++ d_const () (CStr s) ++ chr ')' + | AlignOf (t) -> + text "__alignof__(" ++ self#pType None () t ++ chr ')' + | AlignOfE (e) -> + text "__alignof__(" ++ self#pExp () e ++ chr ')' + + | StartOf lv -> dprintf "StartOf(%a)" self#pLval lv + | AddrOf (lv) -> dprintf "AddrOf(%a)" self#pLval lv + + + + method private d_plainoffset () = function + NoOffset -> text "NoOffset" + | Field(fi,o) -> + dprintf "Field(@[%s:%a,@?%a@])" + fi.fname self#pOnlyType fi.ftype self#d_plainoffset o + | Index(e, o) -> + dprintf "Index(@[%a,@?%a@])" self#pExp e self#d_plainoffset o + + method pInit () = function + SingleInit e -> dprintf "SI(%a)" d_exp e + | CompoundInit (t, initl) -> + let d_plainoneinit (o, i) = + self#d_plainoffset () o ++ text " = " ++ self#pInit () i + in + dprintf "CI(@[%a,@?%a@])" self#pOnlyType t + (docList ~sep:(chr ',' ++ break) d_plainoneinit) initl +(* + | ArrayInit (t, len, initl) -> + let idx = ref (- 1) in + let d_plainoneinit i = + incr idx; + text "[" ++ num !idx ++ text "] = " ++ self#pInit () i + in + dprintf "AI(@[%a,%d,@?%a@])" self#pOnlyType t len + (docList ~sep:(chr ',' ++ break) d_plainoneinit) initl +*) + method pLval () (lv: lval) = + match lv with + | Var vi, o -> dprintf "Var(@[%s,@?%a@])" vi.vname self#d_plainoffset o + | Mem e, o -> dprintf "Mem(@[%a,@?%a@])" self#pExp e self#d_plainoffset o + + +end +let plainCilPrinter = new plainCilPrinterClass + +(* And now some shortcuts *) +let d_plainexp () e = plainCilPrinter#pExp () e +let d_plaintype () t = plainCilPrinter#pType None () t +let d_plaininit () i = plainCilPrinter#pInit () i +let d_plainlval () l = plainCilPrinter#pLval () l + +(* zra: this allows pretty printers not in cil.ml to + be exposed to cilmain.ml *) +let printerForMaincil = ref defaultCilPrinter + +let rec d_typsig () = function + TSArray (ts, eo, al) -> + dprintf "TSArray(@[%a,@?%a,@?%a@])" + d_typsig ts + insert (text (match eo with None -> "None" + | Some e -> "Some " ^ Int64.to_string e)) + d_attrlist al + | TSPtr (ts, al) -> + dprintf "TSPtr(@[%a,@?%a@])" + d_typsig ts d_attrlist al + | TSComp (iss, name, al) -> + dprintf "TSComp(@[%s %s,@?%a@])" + (if iss then "struct" else "union") name + d_attrlist al + | TSFun (rt, args, isva, al) -> + dprintf "TSFun(@[%a,@?%a,%b,@?%a@])" + d_typsig rt + (docList ~sep:(chr ',' ++ break) (d_typsig ())) args isva + d_attrlist al + | TSEnum (n, al) -> + dprintf "TSEnum(@[%s,@?%a@])" + n d_attrlist al + | TSBase t -> dprintf "TSBase(%a)" d_type t + + +let newVID () = + let t = !nextGlobalVID in + incr nextGlobalVID; + t + + (* Make a varinfo. Used mostly as a helper function below *) +let makeVarinfo global name typ = + (* Strip const from type for locals *) + let vi = + { vname = name; + vid = newVID (); + vglob = global; + vtype = if global then typ else typeRemoveAttributes ["const"] typ; + vdecl = lu; + vinline = false; + vattr = []; + vstorage = NoStorage; + vaddrof = false; + vreferenced = false; (* sm *) + } in + vi + +let copyVarinfo (vi: varinfo) (newname: string) : varinfo = + let vi' = {vi with vname = newname; vid = newVID () } in + vi' + +let makeLocal fdec name typ = (* a helper function *) + fdec.smaxid <- 1 + fdec.smaxid; + let vi = makeVarinfo false name typ in + vi + + (* Make a local variable and add it to a function *) +let makeLocalVar fdec ?(insert = true) name typ = + let vi = makeLocal fdec name typ in + if insert then fdec.slocals <- fdec.slocals @ [vi]; + vi + + +let makeTempVar fdec ?(name = "__cil_tmp") typ : varinfo = + let name = name ^ (string_of_int (1 + fdec.smaxid)) in + makeLocalVar fdec name typ + + + (* Set the formals and re-create the function name based on the information*) +let setFormals (f: fundec) (forms: varinfo list) = + f.sformals <- forms; (* Set the formals *) + match unrollType f.svar.vtype with + TFun(rt, _, isva, fa) -> + f.svar.vtype <- + TFun(rt, + Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) forms), + isva, fa) + | _ -> E.s (E.bug "Set formals. %s does not have function type\n" + f.svar.vname) + + (* Set the types of arguments and results as given by the function type + * passed as the second argument *) +let setFunctionType (f: fundec) (t: typ) = + match unrollType t with + TFun (rt, Some args, va, a) -> + if List.length f.sformals <> List.length args then + E.s (E.bug "setFunctionType: number of arguments differs from the number of formals"); + (* Change the function type. *) + f.svar.vtype <- t; + (* Change the sformals and we know that indirectly we'll change the + * function type *) + List.iter2 + (fun (an,at,aa) f -> + f.vtype <- at; f.vattr <- aa) + args f.sformals + + | _ -> E.s (E.bug "setFunctionType: not a function type") + + + (* Set the types of arguments and results as given by the function type + * passed as the second argument *) +let setFunctionTypeMakeFormals (f: fundec) (t: typ) = + match unrollType t with + TFun (rt, Some args, va, a) -> + if f.sformals <> [] then + E.s (E.warn "setFunctionTypMakeFormals called on function %s with some formals already" + f.svar.vname); + (* Change the function type. *) + f.svar.vtype <- t; + f.sformals <- []; + + f.sformals <- List.map (fun (n,t,a) -> makeLocal f n t) args; + + setFunctionType f t + + | _ -> E.s (E.bug "setFunctionTypeMakeFormals: not a function type: %a" + d_type t) + + +let setMaxId (f: fundec) = + f.smaxid <- List.length f.sformals + List.length f.slocals + + + (* Make a formal variable for a function. Insert it in both the sformals + * and the type of the function. You can optionally specify where to insert + * this one. If where = "^" then it is inserted first. If where = "$" then + * it is inserted last. Otherwise where must be the name of a formal after + * which to insert this. By default it is inserted at the end. *) +let makeFormalVar fdec ?(where = "$") name typ : varinfo = + (* Search for the insertion place *) + let thenewone = ref fdec.svar in (* Just a placeholder *) + let makeit () : varinfo = + let vi = makeLocal fdec name typ in + thenewone := vi; + vi + in + let rec loopFormals = function + [] -> + if where = "$" then [makeit ()] + else E.s (E.error "makeFormalVar: cannot find insert-after formal %s" + where) + | f :: rest when f.vname = where -> f :: makeit () :: rest + | f :: rest -> f :: loopFormals rest + in + let newformals = + if where = "^" then makeit () :: fdec.sformals else + loopFormals fdec.sformals in + setFormals fdec newformals; + !thenewone + + (* Make a global variable. Your responsibility to make sure that the name + * is unique *) +let makeGlobalVar name typ = + let vi = makeVarinfo true name typ in + vi + + + (* Make an empty function *) +let emptyFunction name = + { svar = makeGlobalVar name (TFun(voidType, Some [], false,[])); + smaxid = 0; + slocals = []; + sformals = []; + sbody = mkBlock []; + smaxstmtid = None; + sallstmts = []; + } + + + + (* A dummy function declaration handy for initialization *) +let dummyFunDec = emptyFunction "@dummy" +let dummyFile = + { globals = []; + fileName = ""; + globinit = None; + globinitcalled = false;} + +let saveBinaryFile (cil_file : file) (filename : string) = + let outchan = open_out_bin filename in + Marshal.to_channel outchan cil_file [] ; + close_out outchan + +let saveBinaryFileChannel (cil_file : file) (outchan : out_channel) = + Marshal.to_channel outchan cil_file [] + +let loadBinaryFile (filename : string) : file = + let inchan = open_in_bin filename in + let cil_file = (Marshal.from_channel inchan : file) in + close_in inchan ; + cil_file + + +(* Take the name of a file and make a valid symbol name out of it. There are + * a few chanracters that are not valid in symbols *) +let makeValidSymbolName (s: string) = + let s = String.copy s in (* So that we can update in place *) + let l = String.length s in + for i = 0 to l - 1 do + let c = String.get s i in + let isinvalid = + match c with + '-' | '.' -> true + | _ -> false + in + if isinvalid then + String.set s i '_'; + done; + s + + +(*** Define the visiting engine ****) +(* visit all the nodes in a Cil expression *) +let doVisit (vis: cilVisitor) + (startvisit: 'a -> 'a visitAction) + (children: cilVisitor -> 'a -> 'a) + (node: 'a) : 'a = + let action = startvisit node in + match action with + SkipChildren -> node + | ChangeTo node' -> node' + | _ -> (* DoChildren and ChangeDoChildrenPost *) + let nodepre = match action with + ChangeDoChildrenPost (node', _) -> node' + | _ -> node + in + let nodepost = children vis nodepre in + match action with + ChangeDoChildrenPost (_, f) -> f nodepost + | _ -> nodepost + +(* mapNoCopy is like map but avoid copying the list if the function does not + * change the elements. *) +let rec mapNoCopy (f: 'a -> 'a) = function + [] -> [] + | (i :: resti) as li -> + let i' = f i in + let resti' = mapNoCopy f resti in + if i' != i || resti' != resti then i' :: resti' else li + +let rec mapNoCopyList (f: 'a -> 'a list) = function + [] -> [] + | (i :: resti) as li -> + let il' = f i in + let resti' = mapNoCopyList f resti in + match il' with + [i'] when i' == i && resti' == resti -> li + | _ -> il' @ resti' + +(* A visitor for lists *) +let doVisitList (vis: cilVisitor) + (startvisit: 'a -> 'a list visitAction) + (children: cilVisitor -> 'a -> 'a) + (node: 'a) : 'a list = + let action = startvisit node in + match action with + SkipChildren -> [node] + | ChangeTo nodes' -> nodes' + | _ -> + let nodespre = match action with + ChangeDoChildrenPost (nodespre, _) -> nodespre + | _ -> [node] + in + let nodespost = mapNoCopy (children vis) nodespre in + match action with + ChangeDoChildrenPost (_, f) -> f nodespost + | _ -> nodespost + +let debugVisit = false + +let rec visitCilExpr (vis: cilVisitor) (e: exp) : exp = + doVisit vis vis#vexpr childrenExp e +and childrenExp (vis: cilVisitor) (e: exp) : exp = + let vExp e = visitCilExpr vis e in + let vTyp t = visitCilType vis t in + let vLval lv = visitCilLval vis lv in + match e with + | Const (CEnum(v, s, ei)) -> + let v' = vExp v in + if v' != v then Const (CEnum(v', s, ei)) else e + + | Const _ -> e + | SizeOf t -> + let t'= vTyp t in + if t' != t then SizeOf t' else e + | SizeOfE e1 -> + let e1' = vExp e1 in + if e1' != e1 then SizeOfE e1' else e + | SizeOfStr s -> e + + | AlignOf t -> + let t' = vTyp t in + if t' != t then AlignOf t' else e + | AlignOfE e1 -> + let e1' = vExp e1 in + if e1' != e1 then AlignOfE e1' else e + | Lval lv -> + let lv' = vLval lv in + if lv' != lv then Lval lv' else e + | UnOp (uo, e1, t) -> + let e1' = vExp e1 in let t' = vTyp t in + if e1' != e1 || t' != t then UnOp(uo, e1', t') else e + | BinOp (bo, e1, e2, t) -> + let e1' = vExp e1 in let e2' = vExp e2 in let t' = vTyp t in + if e1' != e1 || e2' != e2 || t' != t then BinOp(bo, e1',e2',t') else e + | CastE (t, e1) -> + let t' = vTyp t in let e1' = vExp e1 in + if t' != t || e1' != e1 then CastE(t', e1') else e + | AddrOf lv -> + let lv' = vLval lv in + if lv' != lv then AddrOf lv' else e + | StartOf lv -> + let lv' = vLval lv in + if lv' != lv then StartOf lv' else e + +and visitCilInit (vis: cilVisitor) (i: init) : init = + doVisit vis vis#vinit childrenInit i +and childrenInit (vis: cilVisitor) (i: init) : init = + let fExp e = visitCilExpr vis e in + let fInit i = visitCilInit vis i in + let fTyp t = visitCilType vis t in + match i with + | SingleInit e -> + let e' = fExp e in + if e' != e then SingleInit e' else i + | CompoundInit (t, initl) -> + let t' = fTyp t in + (* Collect the new initializer list, in reverse. We prefer two + * traversals to ensure tail-recursion. *) + let newinitl : (offset * init) list ref = ref [] in + (* Keep track whether the list has changed *) + let hasChanged = ref false in + let doOneInit ((o, i) as oi) = + let o' = visitCilInitOffset vis o in (* use initializer version *) + let i' = fInit i in + let newio = + if o' != o || i' != i then + begin hasChanged := true; (o', i') end else oi + in + newinitl := newio :: !newinitl + in + List.iter doOneInit initl; + let initl' = if !hasChanged then List.rev !newinitl else initl in + if t' != t || initl' != initl then CompoundInit (t', initl') else i + +and visitCilLval (vis: cilVisitor) (lv: lval) : lval = + doVisit vis vis#vlval childrenLval lv +and childrenLval (vis: cilVisitor) (lv: lval) : lval = + (* and visit its subexpressions *) + let vExp e = visitCilExpr vis e in + let vOff off = visitCilOffset vis off in + match lv with + Var v, off -> + let v' = doVisit vis vis#vvrbl (fun _ x -> x) v in + let off' = vOff off in + if v' != v || off' != off then Var v', off' else lv + | Mem e, off -> + let e' = vExp e in + let off' = vOff off in + if e' != e || off' != off then Mem e', off' else lv + +and visitCilOffset (vis: cilVisitor) (off: offset) : offset = + doVisit vis vis#voffs childrenOffset off +and childrenOffset (vis: cilVisitor) (off: offset) : offset = + let vOff off = visitCilOffset vis off in + match off with + Field (f, o) -> + let o' = vOff o in + if o' != o then Field (f, o') else off + | Index (e, o) -> + let e' = visitCilExpr vis e in + let o' = vOff o in + if e' != e || o' != o then Index (e', o') else off + | NoOffset -> off + +(* sm: for offsets in initializers, the 'startvisit' will be the + * vinitoffs method, but we can re-use the childrenOffset from + * above since recursive offsets are visited by voffs. (this point + * is moot according to cil.mli which claims the offsets in + * initializers will never recursively contain offsets) + *) +and visitCilInitOffset (vis: cilVisitor) (off: offset) : offset = + doVisit vis vis#vinitoffs childrenOffset off + +and visitCilInstr (vis: cilVisitor) (i: instr) : instr list = + let oldloc = !currentLoc in + currentLoc := (get_instrLoc i); + assertEmptyQueue vis; + let res = doVisitList vis vis#vinst childrenInstr i in + currentLoc := oldloc; + (* See if we have accumulated some instructions *) + vis#unqueueInstr () @ res + +and childrenInstr (vis: cilVisitor) (i: instr) : instr = + let fExp = visitCilExpr vis in + let fLval = visitCilLval vis in + match i with + | Set(lv,e,l) -> + let lv' = fLval lv in let e' = fExp e in + if lv' != lv || e' != e then Set(lv',e',l) else i + | Call(None,f,args,l) -> + let f' = fExp f in let args' = mapNoCopy fExp args in + if f' != f || args' != args then Call(None,f',args',l) else i + | Call(Some lv,fn,args,l) -> + let lv' = fLval lv in let fn' = fExp fn in + let args' = mapNoCopy fExp args in + if lv' != lv || fn' != fn || args' != args + then Call(Some lv', fn', args', l) else i + + | Asm(sl,isvol,outs,ins,clobs,l) -> + let outs' = mapNoCopy (fun ((s,lv) as pair) -> + let lv' = fLval lv in + if lv' != lv then (s,lv') else pair) outs in + let ins' = mapNoCopy (fun ((s,e) as pair) -> + let e' = fExp e in + if e' != e then (s,e') else pair) ins in + if outs' != outs || ins' != ins then + Asm(sl,isvol,outs',ins',clobs,l) else i + + +(* visit all nodes in a Cil statement tree in preorder *) +and visitCilStmt (vis: cilVisitor) (s: stmt) : stmt = + let oldloc = !currentLoc in + currentLoc := (get_stmtLoc s.skind) ; + assertEmptyQueue vis; + let toPrepend : instr list ref = ref [] in (* childrenStmt may add to this *) + let res = doVisit vis vis#vstmt (childrenStmt toPrepend) s in + (* Now see if we have saved some instructions *) + toPrepend := !toPrepend @ vis#unqueueInstr (); + (match !toPrepend with + [] -> () (* Return the same statement *) + | _ -> + (* Make our statement contain the instructions to prepend *) + res.skind <- Block { battrs = []; bstmts = [ mkStmt (Instr !toPrepend); + mkStmt res.skind ] }); + currentLoc := oldloc; + res + +and childrenStmt (toPrepend: instr list ref) (vis:cilVisitor) (s:stmt): stmt = + let fExp e = (visitCilExpr vis e) in + let fBlock b = visitCilBlock vis b in + let fInst i = visitCilInstr vis i in + (* Just change the statement kind *) + let skind' = + match s.skind with + Break _ | Continue _ | Goto _ | Return (None, _) -> s.skind + | Return (Some e, l) -> + let e' = fExp e in + if e' != e then Return (Some e', l) else s.skind +(* + | Loop (b, l, s1, s2) -> + let b' = fBlock b in + if b' != b then Loop (b', l, s1, s2) else s.skind +*) + | While (e, b, l) -> + let e' = fExp e in + let b' = fBlock b in + if e' != e || b' != b then While (e', b', l) else s.skind + | DoWhile (e, b, l) -> + let b' = fBlock b in + let e' = fExp e in + if e' != e || b' != b then DoWhile (e', b', l) else s.skind + | For (bInit, e, bIter, b, l) -> + let bInit' = fBlock bInit in + let e' = fExp e in + let bIter' = fBlock bIter in + let b' = fBlock b in + if bInit' != bInit || e' != e || bIter' != bIter || b' != b then + For (bInit', e', bIter', b', l) else s.skind + | If(e, s1, s2, l) -> + let e' = fExp e in + (*if e queued any instructions, pop them here and remember them so that + they are inserted before the If stmt, not in the then block. *) + toPrepend := vis#unqueueInstr (); + let s1'= fBlock s1 in let s2'= fBlock s2 in + (* the stmts in the blocks should have cleaned up after themselves.*) + assertEmptyQueue vis; + if e' != e || s1' != s1 || s2' != s2 then + If(e', s1', s2', l) else s.skind + | Switch (e, b, stmts, l) -> + let e' = fExp e in + toPrepend := vis#unqueueInstr (); (* insert these before the switch *) + let b' = fBlock b in + (* the stmts in b should have cleaned up after themselves.*) + assertEmptyQueue vis; + (* Don't do stmts, but we better not change those *) + if e' != e || b' != b then Switch (e', b', stmts, l) else s.skind + | Instr il -> + let il' = mapNoCopyList fInst il in + if il' != il then Instr il' else s.skind + | Block b -> + let b' = fBlock b in + if b' != b then Block b' else s.skind + | TryFinally (b, h, l) -> + let b' = fBlock b in + let h' = fBlock h in + if b' != b || h' != h then TryFinally(b', h', l) else s.skind + | TryExcept (b, (il, e), h, l) -> + let b' = fBlock b in + assertEmptyQueue vis; + (* visit the instructions *) + let il' = mapNoCopyList fInst il in + (* Visit the expression *) + let e' = fExp e in + let il'' = + let more = vis#unqueueInstr () in + if more != [] then + il' @ more + else + il' + in + let h' = fBlock h in + (* Now collect the instructions *) + if b' != b || il'' != il || e' != e || h' != h then + TryExcept(b', (il'', e'), h', l) + else s.skind + in + if skind' != s.skind then s.skind <- skind'; + (* Visit the labels *) + let labels' = + let fLabel = function + Case (e, l) as lb -> + let e' = fExp e in + if e' != e then Case (e', l) else lb + | lb -> lb + in + mapNoCopy fLabel s.labels + in + if labels' != s.labels then s.labels <- labels'; + s + + + +and visitCilBlock (vis: cilVisitor) (b: block) : block = + doVisit vis vis#vblock childrenBlock b +and childrenBlock (vis: cilVisitor) (b: block) : block = + let fStmt s = visitCilStmt vis s in + let stmts' = mapNoCopy fStmt b.bstmts in + if stmts' != b.bstmts then { battrs = b.battrs; bstmts = stmts'} else b + + +and visitCilType (vis : cilVisitor) (t : typ) : typ = + doVisit vis vis#vtype childrenType t +and childrenType (vis : cilVisitor) (t : typ) : typ = + (* look for types referred to inside t's definition *) + let fTyp t = visitCilType vis t in + let fAttr a = visitCilAttributes vis a in + match t with + TPtr(t1, a) -> + let t1' = fTyp t1 in + let a' = fAttr a in + if t1' != t || a' != a then TPtr(t1', a') else t + | TArray(t1, None, a) -> + let t1' = fTyp t1 in + let a' = fAttr a in + if t1' != t || a' != a then TArray(t1', None, a') else t + | TArray(t1, Some e, a) -> + let t1' = fTyp t1 in + let e' = visitCilExpr vis e in + let a' = fAttr a in + if t1' != t || e' != e || a' != a then TArray(t1', Some e', a') else t + + (* DON'T recurse into the compinfo, this is done in visitCilGlobal. + User can iterate over cinfo.cfields manually, if desired.*) + | TComp(cinfo, a) -> + let a' = fAttr a in + if a != a' then TComp(cinfo, a') else t + + | TFun(rettype, args, isva, a) -> + let rettype' = fTyp rettype in + (* iterate over formals, as variable declarations *) + let argslist = argsToList args in + let visitArg ((an,at,aa) as arg) = + let at' = fTyp at in + let aa' = fAttr aa in + if at' != at || aa' != aa then (an,at',aa') else arg + in + let argslist' = mapNoCopy visitArg argslist in + let a' = fAttr a in + if rettype' != rettype || argslist' != argslist || a' != a then + let args' = if argslist' == argslist then args else Some argslist' in + TFun(rettype', args', isva, a') else t + + | TNamed(t1, a) -> (* Do not go into the type. Will do it at the time of + * GType *) + let a' = fAttr a in + if a' != a then TNamed (t1, a') else t + + | _ -> (* other types (TVoid, TInt, TFloat, TEnum, and TBuiltin_va_list) + don't contain nested types, but they do have attributes. *) + let a = typeAttrs t in + let a' = fAttr a in + if a' != a then setTypeAttrs t a' else t + + +(* for declarations, we visit the types inside; but for uses, *) +(* we just visit the varinfo node *) +and visitCilVarDecl (vis : cilVisitor) (v : varinfo) : varinfo = + doVisit vis vis#vvdec childrenVarDecl v +and childrenVarDecl (vis : cilVisitor) (v : varinfo) : varinfo = + v.vtype <- visitCilType vis v.vtype; + v.vattr <- visitCilAttributes vis v.vattr; + v + +and visitCilAttributes (vis: cilVisitor) (al: attribute list) : attribute list= + let al' = + mapNoCopyList (doVisitList vis vis#vattr childrenAttribute) al in + if al' != al then + (* Must re-sort *) + addAttributes al' [] + else + al +and childrenAttribute (vis: cilVisitor) (a: attribute) : attribute = + let fAttrP a = visitCilAttrParams vis a in + match a with + Attr (n, args) -> + let args' = mapNoCopy fAttrP args in + if args' != args then Attr(n, args') else a + + +and visitCilAttrParams (vis: cilVisitor) (a: attrparam) : attrparam = + doVisit vis vis#vattrparam childrenAttrparam a +and childrenAttrparam (vis: cilVisitor) (aa: attrparam) : attrparam = + let fTyp t = visitCilType vis t in + let fAttrP a = visitCilAttrParams vis a in + match aa with + AInt _ | AStr _ -> aa + | ACons(n, args) -> + let args' = mapNoCopy fAttrP args in + if args' != args then ACons(n, args') else aa + | ASizeOf t -> + let t' = fTyp t in + if t' != t then ASizeOf t' else aa + | ASizeOfE e -> + let e' = fAttrP e in + if e' != e then ASizeOfE e' else aa + | AAlignOf t -> + let t' = fTyp t in + if t' != t then AAlignOf t' else aa + | AAlignOfE e -> + let e' = fAttrP e in + if e' != e then AAlignOfE e' else aa + | ASizeOfS _ | AAlignOfS _ -> + ignore (warn "Visitor inside of a type signature."); + aa + | AUnOp (uo, e1) -> + let e1' = fAttrP e1 in + if e1' != e1 then AUnOp (uo, e1') else aa + | ABinOp (bo, e1, e2) -> + let e1' = fAttrP e1 in + let e2' = fAttrP e2 in + if e1' != e1 || e2' != e2 then ABinOp (bo, e1', e2') else aa + | ADot (ap, s) -> + let ap' = fAttrP ap in + if ap' != ap then ADot (ap', s) else aa + + +let rec visitCilFunction (vis : cilVisitor) (f : fundec) : fundec = + if debugVisit then ignore (E.log "Visiting function %s\n" f.svar.vname); + assertEmptyQueue vis; + let f = doVisit vis vis#vfunc childrenFunction f in + + let toPrepend = vis#unqueueInstr () in + if toPrepend <> [] then + f.sbody.bstmts <- mkStmt (Instr toPrepend) :: f.sbody.bstmts; + f + +and childrenFunction (vis : cilVisitor) (f : fundec) : fundec = + f.svar <- visitCilVarDecl vis f.svar; (* hit the function name *) + (* visit local declarations *) + f.slocals <- mapNoCopy (visitCilVarDecl vis) f.slocals; + (* visit the formals *) + let newformals = mapNoCopy (visitCilVarDecl vis) f.sformals in + (* Make sure the type reflects the formals *) + setFormals f newformals; + (* Remember any new instructions that were generated while visiting + variable declarations. *) + let toPrepend = vis#unqueueInstr () in + + f.sbody <- visitCilBlock vis f.sbody; (* visit the body *) + if toPrepend <> [] then + f.sbody.bstmts <- mkStmt (Instr toPrepend) :: f.sbody.bstmts; + f + +let rec visitCilGlobal (vis: cilVisitor) (g: global) : global list = + (*(trace "visit" (dprintf "visitCilGlobal\n"));*) + let oldloc = !currentLoc in + currentLoc := (get_globalLoc g) ; + currentGlobal := g; + let res = doVisitList vis vis#vglob childrenGlobal g in + currentLoc := oldloc; + res +and childrenGlobal (vis: cilVisitor) (g: global) : global = + match g with + | GFun (f, l) -> + let f' = visitCilFunction vis f in + if f' != f then GFun (f', l) else g + | GType(t, l) -> + t.ttype <- visitCilType vis t.ttype; + g + + | GEnumTagDecl _ | GCompTagDecl _ -> g (* Nothing to visit *) + | GEnumTag (enum, _) -> + (trace "visit" (dprintf "visiting global enum %s\n" enum.ename)); + (* Do the values and attributes of the enumerated items *) + let itemVisit (name, exp, loc) = (name, visitCilExpr vis exp, loc) in + enum.eitems <- mapNoCopy itemVisit enum.eitems; + enum.eattr <- visitCilAttributes vis enum.eattr; + g + + | GCompTag (comp, _) -> + (trace "visit" (dprintf "visiting global comp %s\n" comp.cname)); + (* Do the types and attirbutes of the fields *) + let fieldVisit = fun fi -> + fi.ftype <- visitCilType vis fi.ftype; + fi.fattr <- visitCilAttributes vis fi.fattr + in + List.iter fieldVisit comp.cfields; + comp.cattr <- visitCilAttributes vis comp.cattr; + g + + | GVarDecl(v, l) -> + let v' = visitCilVarDecl vis v in + if v' != v then GVarDecl (v', l) else g + | GVar (v, inito, l) -> + let v' = visitCilVarDecl vis v in + (match inito.init with + None -> () + | Some i -> let i' = visitCilInit vis i in + if i' != i then inito.init <- Some i'); + + if v' != v then GVar (v', inito, l) else g + + | GPragma (a, l) -> begin + match visitCilAttributes vis [a] with + [a'] -> if a' != a then GPragma (a', l) else g + | _ -> E.s (E.unimp "visitCilAttributes returns more than one attribute") + end + | _ -> g + + +(** A visitor that does constant folding. If "machdep" is true then we do + * machine dependent simplification (e.g., sizeof) *) +class constFoldVisitorClass (machdep: bool) : cilVisitor = object + inherit nopCilVisitor + + method vinst i = + match i with + (* Skip two functions to which we add Sizeof to the type arguments. + See the comments for these above. *) + Call(_,(Lval (Var vi,NoOffset)),_,_) + when ((vi.vname = "__builtin_va_arg") + || (vi.vname = "__builtin_types_compatible_p")) -> + SkipChildren + | _ -> DoChildren + method vexpr (e: exp) = + (* Do it bottom up *) + ChangeDoChildrenPost (e, constFold machdep) + +end +let constFoldVisitor (machdep: bool) = new constFoldVisitorClass machdep + +(* Iterate over all globals, including the global initializer *) +let iterGlobals (fl: file) + (doone: global -> unit) : unit = + let doone' g = + currentLoc := get_globalLoc g; + doone g + in + List.iter doone' fl.globals; + (match fl.globinit with + None -> () + | Some g -> doone' (GFun(g, locUnknown))) + +(* Fold over all globals, including the global initializer *) +let foldGlobals (fl: file) + (doone: 'a -> global -> 'a) + (acc: 'a) : 'a = + let doone' acc g = + currentLoc := get_globalLoc g; + doone acc g + in + let acc' = List.fold_left doone' acc fl.globals in + (match fl.globinit with + None -> acc' + | Some g -> doone' acc' (GFun(g, locUnknown))) + + +(* A visitor for the whole file that does not change the globals *) +let visitCilFileSameGlobals (vis : cilVisitor) (f : file) : unit = + let fGlob g = visitCilGlobal vis g in + iterGlobals f (fun g -> + match fGlob g with + [g'] when g' == g || Util.equals g' g -> () (* Try to do the pointer check first *) + | gl -> + ignore (E.log "You used visitCilFilSameGlobals but the global got changed:\n %a\nchanged to %a\n" d_global g (docList ~sep:line (d_global ())) gl); + ()) + +(* Be careful with visiting the whole file because it might be huge. *) +let visitCilFile (vis : cilVisitor) (f : file) : unit = + let fGlob g = visitCilGlobal vis g in + (* Scan the globals. Make sure this is tail recursive. *) + let rec loop (acc: global list) = function + [] -> f.globals <- List.rev acc + | g :: restg -> + loop ((List.rev (fGlob g)) @ acc) restg + in + loop [] f.globals; + (* the global initializer *) + (match f.globinit with + None -> () + | Some g -> f.globinit <- Some (visitCilFunction vis g)) + + + +(** Create or fetch the global initializer. Tries to put a call to in the the + * function with the main_name *) +let getGlobInit ?(main_name="main") (fl: file) = + match fl.globinit with + Some f -> f + | None -> begin + (* Sadly, we cannot use the Filename library because it does not like + * function names with multiple . in them *) + let f = + let len = String.length fl.fileName in + (* Find the last path separator and record the first . that we see, + * going backwards *) + let lastDot = ref len in + let rec findLastPathSep i = + if i < 0 then -1 else + let c = String.get fl.fileName i in + if c = '/' || c = '\\' then i + else begin + if c = '.' && !lastDot = len then + lastDot := i; + findLastPathSep (i - 1) + end + in + let lastPathSep = findLastPathSep (len - 1) in + let basenoext = + String.sub fl.fileName (lastPathSep + 1) (!lastDot - lastPathSep - 1) + in + emptyFunction + (makeValidSymbolName ("__globinit_" ^ basenoext)) + in + fl.globinit <- Some f; + (* Now try to add a call to the global initialized at the beginning of + * main *) + let inserted = ref false in + List.iter + (fun g -> + match g with + GFun(m, lm) when m.svar.vname = main_name -> + (* Prepend a prototype to the global initializer *) + fl.globals <- GVarDecl (f.svar, lm) :: fl.globals; + m.sbody.bstmts <- + compactStmts (mkStmt (Instr [Call(None, + Lval(var f.svar), + [], locUnknown)]) + :: m.sbody.bstmts); + inserted := true; + if !E.verboseFlag then + ignore (E.log "Inserted the globinit\n"); + fl.globinitcalled <- true; + | _ -> ()) + fl.globals; + + if not !inserted then + ignore (E.warn "Cannot find %s to add global initializer %s" + main_name f.svar.vname); + + f + end + + + +(* Fold over all globals, including the global initializer *) +let mapGlobals (fl: file) + (doone: global -> global) : unit = + fl.globals <- List.map doone fl.globals; + (match fl.globinit with + None -> () + | Some g -> begin + match doone (GFun(g, locUnknown)) with + GFun(g', _) -> fl.globinit <- Some g' + | _ -> E.s (E.bug "mapGlobals: globinit is not a function") + end) + + + +let dumpFile (pp: cilPrinter) (out : out_channel) (outfile: string) file = + printDepth := 99999; (* We don't want ... in the output *) + (* If we are in RELEASE mode then we do not print indentation *) + + Pretty.fastMode := true; + + if !E.verboseFlag then + ignore (E.log "printing file %s\n" outfile); + let print x = fprint out 78 x in + print (text ("/* Generated by CIL v. " ^ cilVersion ^ " */\n" ^ + (* sm: I want to easily tell whether the generated output + * is with print_CIL_Input or not *) + "/* print_CIL_Input is " ^ (if !print_CIL_Input then "true" else "false") ^ " */\n\n")); + iterGlobals file (fun g -> dumpGlobal pp out g); + + (* sm: we have to flush the output channel; if we don't then under *) + (* some circumstances (I haven't figure out exactly when, but it happens *) + (* more often with big inputs), we get a truncated output file *) + flush out + + + +(****************** + ****************** + ******************) + + + +(******************** OPTIMIZATIONS *****) +let rec peepHole1 (* Process one statement and possibly replace it *) + (doone: instr -> instr list option) + (* Scan a block and recurse inside nested blocks *) + (ss: stmt list) : unit = + let rec doInstrList (il: instr list) : instr list = + match il with + [] -> [] + | i :: rest -> begin + match doone i with + None -> i :: doInstrList rest + | Some sl -> doInstrList (sl @ rest) + end + in + + List.iter + (fun s -> + match s.skind with + Instr il -> s.skind <- Instr (doInstrList il) + | If (e, tb, eb, _) -> + peepHole1 doone tb.bstmts; + peepHole1 doone eb.bstmts + | Switch (e, b, _, _) -> peepHole1 doone b.bstmts +(* + | Loop (b, l, _, _) -> peepHole1 doone b.bstmts +*) + | While (_, b, _) -> peepHole1 doone b.bstmts + | DoWhile (_, b, _) -> peepHole1 doone b.bstmts + | For (bInit, _, bIter, b, _) -> + peepHole1 doone bInit.bstmts; + peepHole1 doone bIter.bstmts; + peepHole1 doone b.bstmts + | Block b -> peepHole1 doone b.bstmts + | TryFinally (b, h, l) -> + peepHole1 doone b.bstmts; + peepHole1 doone h.bstmts + | TryExcept (b, (il, e), h, l) -> + peepHole1 doone b.bstmts; + peepHole1 doone h.bstmts; + s.skind <- TryExcept(b, (doInstrList il, e), h, l); + | Return _ | Goto _ | Break _ | Continue _ -> ()) + ss + +let rec peepHole2 (* Process two statements and possibly replace them both *) + (dotwo: instr * instr -> instr list option) + (ss: stmt list) : unit = + let rec doInstrList (il: instr list) : instr list = + match il with + [] -> [] + | [i] -> [i] + | (i1 :: ((i2 :: rest) as rest2)) -> + begin + match dotwo (i1,i2) with + None -> i1 :: doInstrList rest2 + | Some sl -> doInstrList (sl @ rest) + end + in + List.iter + (fun s -> + match s.skind with + Instr il -> s.skind <- Instr (doInstrList il) + | If (e, tb, eb, _) -> + peepHole2 dotwo tb.bstmts; + peepHole2 dotwo eb.bstmts + | Switch (e, b, _, _) -> peepHole2 dotwo b.bstmts +(* + | Loop (b, l, _, _) -> peepHole2 dotwo b.bstmts +*) + | While (_, b, _) -> peepHole2 dotwo b.bstmts + | DoWhile (_, b, _) -> peepHole2 dotwo b.bstmts + | For (bInit, _, bIter, b, _) -> + peepHole2 dotwo bInit.bstmts; + peepHole2 dotwo bIter.bstmts; + peepHole2 dotwo b.bstmts + | Block b -> peepHole2 dotwo b.bstmts + | TryFinally (b, h, l) -> peepHole2 dotwo b.bstmts; + peepHole2 dotwo h.bstmts + | TryExcept (b, (il, e), h, l) -> + peepHole2 dotwo b.bstmts; + peepHole2 dotwo h.bstmts; + s.skind <- TryExcept (b, (doInstrList il, e), h, l) + + | Return _ | Goto _ | Break _ | Continue _ -> ()) + ss + + + + +(*** Type signatures ***) + +(* Helper class for typeSig: replace any types in attributes with typsigs *) +class typeSigVisitor(typeSigConverter: typ->typsig) = object + inherit nopCilVisitor + method vattrparam ap = + match ap with + | ASizeOf t -> ChangeTo (ASizeOfS (typeSigConverter t)) + | AAlignOf t -> ChangeTo (AAlignOfS (typeSigConverter t)) + | _ -> DoChildren +end + +let typeSigAddAttrs a0 t = + if a0 == [] then t else + match t with + TSBase t -> TSBase (typeAddAttributes a0 t) + | TSPtr (ts, a) -> TSPtr (ts, addAttributes a0 a) + | TSArray (ts, l, a) -> TSArray(ts, l, addAttributes a0 a) + | TSComp (iss, n, a) -> TSComp (iss, n, addAttributes a0 a) + | TSEnum (n, a) -> TSEnum (n, addAttributes a0 a) + | TSFun(ts, tsargs, isva, a) -> TSFun(ts, tsargs, isva, addAttributes a0 a) + +(* Compute a type signature. + Use ~ignoreSign:true to convert all signed integer types to unsigned, + so that signed and unsigned will compare the same. *) +let rec typeSigWithAttrs ?(ignoreSign=false) doattr t = + let typeSig = typeSigWithAttrs ~ignoreSign doattr in + let attrVisitor = new typeSigVisitor typeSig in + let doattr al = visitCilAttributes attrVisitor (doattr al) in + match t with + | TInt (ik, al) -> + let ik' = if ignoreSign then begin + match ik with + | ISChar | IChar -> IUChar + | IShort -> IUShort + | IInt -> IUInt + | ILong -> IULong + | ILongLong -> IULongLong + | _ -> ik + end else + ik + in + TSBase (TInt (ik', doattr al)) + | TFloat (fk, al) -> TSBase (TFloat (fk, doattr al)) + | TVoid al -> TSBase (TVoid (doattr al)) + | TEnum (enum, a) -> TSEnum (enum.ename, doattr a) + | TPtr (t, a) -> TSPtr (typeSig t, doattr a) + | TArray (t,l,a) -> (* We do not want fancy expressions in array lengths. + * So constant fold the lengths *) + let l' = + match l with + Some l -> begin + match constFold true l with + Const(CInt64(i, _, _)) -> Some i + | e -> E.s (E.bug "Invalid length in array type: %a\n" + (!pd_exp) e) + end + | None -> None + in + TSArray(typeSig t, l', doattr a) + + | TComp (comp, a) -> + TSComp (comp.cstruct, comp.cname, doattr (addAttributes comp.cattr a)) + | TFun(rt,args,isva,a) -> + TSFun(typeSig rt, + List.map (fun (_, atype, _) -> (typeSig atype)) (argsToList args), + isva, doattr a) + | TNamed(t, a) -> typeSigAddAttrs (doattr a) (typeSig t.ttype) + | TBuiltin_va_list al -> TSBase (TBuiltin_va_list (doattr al)) + +let typeSig t = + typeSigWithAttrs (fun al -> al) t + +let _ = pTypeSig := typeSig + +(* Remove the attribute from the top-level of the type signature *) +let setTypeSigAttrs (a: attribute list) = function + TSBase t -> TSBase (setTypeAttrs t a) + | TSPtr (ts, _) -> TSPtr (ts, a) + | TSArray (ts, l, _) -> TSArray(ts, l, a) + | TSComp (iss, n, _) -> TSComp (iss, n, a) + | TSEnum (n, _) -> TSEnum (n, a) + | TSFun (ts, tsargs, isva, _) -> TSFun (ts, tsargs, isva, a) + + +let typeSigAttrs = function + TSBase t -> typeAttrs t + | TSPtr (ts, a) -> a + | TSArray (ts, l, a) -> a + | TSComp (iss, n, a) -> a + | TSEnum (n, a) -> a + | TSFun (ts, tsargs, isva, a) -> a + + + +let dExp: doc -> exp = + fun d -> Const(CStr(sprint !lineLength d)) + +let dInstr: doc -> location -> instr = + fun d l -> Asm([], [sprint !lineLength d], [], [], [], l) + +let dGlobal: doc -> location -> global = + fun d l -> GAsm(sprint !lineLength d, l) + +let rec addOffset (toadd: offset) (off: offset) : offset = + match off with + NoOffset -> toadd + | Field(fid', offset) -> Field(fid', addOffset toadd offset) + | Index(e, offset) -> Index(e, addOffset toadd offset) + + (* Add an offset at the end of an lv *) +let addOffsetLval toadd (b, off) : lval = + b, addOffset toadd off + +let rec removeOffset (off: offset) : offset * offset = + match off with + NoOffset -> NoOffset, NoOffset + | Field(f, NoOffset) -> NoOffset, off + | Index(i, NoOffset) -> NoOffset, off + | Field(f, restoff) -> + let off', last = removeOffset restoff in + Field(f, off'), last + | Index(i, restoff) -> + let off', last = removeOffset restoff in + Index(i, off'), last + +let removeOffsetLval ((b, off): lval) : lval * offset = + let off', last = removeOffset off in + (b, off'), last + + (* Make an AddrOf. Given an lval of type T will give back an expression of + * type ptr(T) *) +let mkAddrOf ((b, off) as lval) : exp = + (* Never take the address of a register variable *) + (match lval with + Var vi, off when vi.vstorage = Register -> vi.vstorage <- NoStorage + | _ -> ()); + match lval with + Mem e, NoOffset -> e + | b, Index(z, NoOffset) when isZero z -> StartOf (b, NoOffset)(* array *) + | _ -> AddrOf lval + + +let mkAddrOrStartOf (lv: lval) : exp = + match unrollType (typeOfLval lv) with + TArray _ -> StartOf lv + | _ -> mkAddrOf lv + + + (* Make a Mem, while optimizing AddrOf. The type of the addr must be + * TPtr(t) and the type of the resulting lval is t. Note that in CIL the + * implicit conversion between a function and a pointer to a function does + * not apply. You must do the conversion yourself using AddrOf *) +let mkMem ~(addr: exp) ~(off: offset) : lval = + let res = + match addr, off with + AddrOf lv, _ -> addOffsetLval off lv + | StartOf lv, _ -> (* Must be an array *) + addOffsetLval (Index(zero, off)) lv + | _, _ -> Mem addr, off + in +(* ignore (E.log "memof : %a:%a\nresult = %a\n" + d_plainexp addr d_plainoffset off d_plainexp res); *) + res + + + +let splitFunctionType (ftype: typ) + : typ * (string * typ * attributes) list option * bool * attributes = + match unrollType ftype with + TFun (rt, args, isva, a) -> rt, args, isva, a + | _ -> E.s (bug "splitFunctionType invoked on a non function type %a" + d_type ftype) + +let splitFunctionTypeVI (fvi: varinfo) + : typ * (string * typ * attributes) list option * bool * attributes = + match unrollType fvi.vtype with + TFun (rt, args, isva, a) -> rt, args, isva, a + | _ -> E.s (bug "Function %s invoked on a non function type" fvi.vname) + +let isArrayType t = + match unrollType t with + TArray _ -> true + | _ -> false + + +let rec isConstant = function + | Const _ -> true + | UnOp (_, e, _) -> isConstant e + | BinOp (_, e1, e2, _) -> isConstant e1 && isConstant e2 + | Lval (Var vi, NoOffset) -> + (vi.vglob && isArrayType vi.vtype || isFunctionType vi.vtype) + | Lval _ -> false + | SizeOf _ | SizeOfE _ | SizeOfStr _ | AlignOf _ | AlignOfE _ -> true + | CastE (_, e) -> isConstant e + | AddrOf (Var vi, off) | StartOf (Var vi, off) + -> vi.vglob && isConstantOff off + | AddrOf (Mem e, off) | StartOf(Mem e, off) + -> isConstant e && isConstantOff off + +and isConstantOff = function + NoOffset -> true + | Field(fi, off) -> isConstantOff off + | Index(e, off) -> isConstant e && isConstantOff off + + +let getCompField (cinfo:compinfo) (fieldName:string) : fieldinfo = + (List.find (fun fi -> fi.fname = fieldName) cinfo.cfields) + + +let rec mkCastT ~(e: exp) ~(oldt: typ) ~(newt: typ) = + (* Do not remove old casts because they are conversions !!! *) + if Util.equals (typeSig oldt) (typeSig newt) then begin + e + end else begin + (* Watch out for constants *) + match newt, e with + TInt(newik, []), Const(CInt64(i, _, _)) -> kinteger64 newik i + | _ -> CastE(newt,e) + end + +let mkCast ~(e: exp) ~(newt: typ) = + mkCastT e (typeOf e) newt + +type existsAction = + ExistsTrue (* We have found it *) + | ExistsFalse (* Stop processing this branch *) + | ExistsMaybe (* This node is not what we are + * looking for but maybe its + * successors are *) +let existsType (f: typ -> existsAction) (t: typ) : bool = + let memo : (int, unit) H.t = H.create 17 in (* Memo table *) + let rec loop t = + match f t with + ExistsTrue -> true + | ExistsFalse -> false + | ExistsMaybe -> + (match t with + TNamed (t', _) -> loop t'.ttype + | TComp (c, _) -> loopComp c + | TArray (t', _, _) -> loop t' + | TPtr (t', _) -> loop t' + | TFun (rt, args, _, _) -> + (loop rt || List.exists (fun (_, at, _) -> loop at) + (argsToList args)) + | _ -> false) + and loopComp c = + if H.mem memo c.ckey then + (* We are looping, the answer must be false *) + false + else begin + H.add memo c.ckey (); + List.exists (fun f -> loop f.ftype) c.cfields + end + in + loop t + + +(* Try to do an increment, with constant folding *) +let increm (e: exp) (i: int) = + let et = typeOf e in + let bop = if isPointerType et then PlusPI else PlusA in + constFold false (BinOp(bop, e, integer i, et)) + +exception LenOfArray +let lenOfArray (eo: exp option) : int = + match eo with + None -> raise LenOfArray + | Some e -> begin + match constFold true e with + | Const(CInt64(ni, _, _)) when ni >= Int64.zero -> + Int64.to_int ni + | e -> raise LenOfArray + end + + +(*** Make a initializer for zeroe-ing a data type ***) +let rec makeZeroInit (t: typ) : init = + match unrollType t with + TInt (ik, _) -> SingleInit (Const(CInt64(Int64.zero, ik, None))) + | TFloat(fk, _) -> SingleInit(Const(CReal(0.0, fk, None))) + | TEnum _ -> SingleInit zero + | TComp (comp, _) as t' when comp.cstruct -> + let inits = + List.fold_right + (fun f acc -> + if f.fname <> missingFieldName then + (Field(f, NoOffset), makeZeroInit f.ftype) :: acc + else + acc) + comp.cfields [] + in + CompoundInit (t', inits) + + | TComp (comp, _) when not comp.cstruct -> + let fstfield, rest = + match comp.cfields with + f :: rest -> f, rest + | [] -> E.s (unimp "Cannot create init for empty union") + in + let fieldToInit = + if !msvcMode then + (* ISO C99 [6.7.8.10] says that the first field of the union + is the one we should initialize. *) + fstfield + else begin + (* gcc initializes the whole union to zero. So choose the largest + field, and set that to zero. Choose the first field if possible. + MSVC also initializes the whole union, but use the ISO behavior + for MSVC because it only allows compound initializers to refer + to the first union field. *) + let fieldSize f = try bitsSizeOf f.ftype with SizeOfError _ -> 0 in + let widestField, widestFieldWidth = + List.fold_left (fun acc thisField -> + let widestField, widestFieldWidth = acc in + let thisSize = fieldSize thisField in + if thisSize > widestFieldWidth then + thisField, thisSize + else + acc) + (fstfield, fieldSize fstfield) + rest + in + widestField + end + in + CompoundInit(t, [(Field(fieldToInit, NoOffset), + makeZeroInit fieldToInit.ftype)]) + + | TArray(bt, Some len, _) as t' -> + let n = + match constFold true len with + Const(CInt64(n, _, _)) -> Int64.to_int n + | _ -> E.s (E.unimp "Cannot understand length of array") + in + let initbt = makeZeroInit bt in + let rec loopElems acc i = + if i < 0 then acc + else loopElems ((Index(integer i, NoOffset), initbt) :: acc) (i - 1) + in + CompoundInit(t', loopElems [] (n - 1)) + + | TArray (bt, None, at) as t' -> + (* Unsized array, allow it and fill it in later + * (see cabs2cil.ml, collectInitializer) *) + CompoundInit (t', []) + + | TPtr _ as t -> SingleInit(CastE(t, zero)) + | x -> E.s (unimp "Cannot initialize type: %a" d_type x) + + +(**** Fold over the list of initializers in a Compound. In the case of an + * array initializer only the initializers present are scanned (a prefix of + * all initializers) *) +let foldLeftCompound + ~(doinit: offset -> init -> typ -> 'a -> 'a) + ~(ct: typ) + ~(initl: (offset * init) list) + ~(acc: 'a) : 'a = + match unrollType ct with + TArray(bt, _, _) -> + List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl + + | TComp (comp, _) -> + let getTypeOffset = function + Field(f, NoOffset) -> f.ftype + | _ -> E.s (bug "foldLeftCompound: malformed initializer") + in + List.fold_left + (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl + + | _ -> E.s (unimp "Type of Compound is not array or struct or union") + +(**** Fold over the list of initializers in a Compound. Like foldLeftCompound + * but scans even the zero-initializers that are missing at the end of the + * array *) +let foldLeftCompoundAll + ~(doinit: offset -> init -> typ -> 'a -> 'a) + ~(ct: typ) + ~(initl: (offset * init) list) + ~(acc: 'a) : 'a = + match unrollType ct with + TArray(bt, leno, _) -> begin + let part = + List.fold_left (fun acc (o, i) -> doinit o i bt acc) acc initl in + (* See how many more we have to do *) + match leno with + Some lene -> begin + match constFold true lene with + Const(CInt64(i, _, _)) -> + let len_array = Int64.to_int i in + let len_init = List.length initl in + if len_array > len_init then + let zi = makeZeroInit bt in + let rec loop acc i = + if i >= len_array then acc + else + loop (doinit (Index(integer i, NoOffset)) zi bt acc) + (i + 1) + in + loop part (len_init + 1) + else + part + | _ -> E.s (unimp "foldLeftCompoundAll: array with initializer and non-constant length\n") + end + + | _ -> E.s (unimp "foldLeftCompoundAll: TArray with initializer and no length") + end + | TComp (comp, _) -> + let getTypeOffset = function + Field(f, NoOffset) -> f.ftype + | _ -> E.s (bug "foldLeftCompound: malformed initializer") + in + List.fold_left + (fun acc (o, i) -> doinit o i (getTypeOffset o) acc) acc initl + + | _ -> E.s (E.unimp "Type of Compound is not array or struct or union") + + + +let rec isCompleteType t = + match unrollType t with + | TArray(t, None, _) -> false + | TArray(t, Some z, _) when isZero z -> false + | TComp (comp, _) -> (* Struct or union *) + List.for_all (fun fi -> isCompleteType fi.ftype) comp.cfields + | _ -> true + + +module A = Alpha + + +(** Uniquefy the variable names *) +let uniqueVarNames (f: file) : unit = + (* Setup the alpha conversion table for globals *) + let gAlphaTable: (string, + location A.alphaTableData ref) H.t = H.create 113 in + (* Keep also track of the global names that we have used. Map them to the + * variable ID. We do this only to check that we do not have two globals + * with the same name. *) + let globalNames: (string, int) H.t = H.create 113 in + (* Scan the file and add the global names to the table *) + iterGlobals f + (function + GVarDecl(vi, l) + | GVar(vi, _, l) + | GFun({svar = vi}, l) -> + (* See if we have used this name already for something else *) + (try + let oldid = H.find globalNames vi.vname in + if oldid <> vi.vid then + ignore (warn "The name %s is used for two distinct globals" + vi.vname); + (* Here if we have used this name already. Go ahead *) + () + with Not_found -> begin + (* Here if this is the first time we define a name *) + H.add globalNames vi.vname vi.vid; + (* And register it *) + A.registerAlphaName gAlphaTable None vi.vname !currentLoc; + () + end) + | _ -> ()); + + (* Now we must scan the function bodies and rename the locals *) + iterGlobals f + (function + GFun(fdec, l) -> begin + currentLoc := l; + (* Setup an undo list to be able to revert the changes to the + * global alpha table *) + let undolist = ref [] in + (* Process one local variable *) + let processLocal (v: varinfo) = + let newname, oldloc = + A.newAlphaName gAlphaTable (Some undolist) v.vname + !currentLoc + in + if false && newname <> v.vname then (* Disable this warning *) + ignore (warn "uniqueVarNames: Changing the name of local %s in %s to %s (due to duplicate at %a)\n" + v.vname fdec.svar.vname newname d_loc oldloc); + v.vname <- newname + in + (* Do the formals first *) + List.iter processLocal fdec.sformals; + (* Fix the type again *) + setFormals fdec fdec.sformals; + (* And now the locals *) + List.iter processLocal fdec.slocals; + (* Undo the changes to the global table *) + A.undoAlphaChanges gAlphaTable !undolist; + () + end + | _ -> ()); + () + + +(* A visitor that makes a deep copy of a function body *) +class copyFunctionVisitor (newname: string) = object (self) + inherit nopCilVisitor + + (* Keep here a maping from locals to their copies *) + val map : (string, varinfo) H.t = H.create 113 + (* Keep here a maping from statements to their copies *) + val stmtmap : (int, stmt) H.t = H.create 113 + val sid = ref 0 (* Will have to assign ids to statements *) + (* Keep here a list of statements to be patched *) + val patches : stmt list ref = ref [] + + val argid = ref 0 + + (* This is the main function *) + method vfunc (f: fundec) : fundec visitAction = + (* We need a map from the old locals/formals to the new ones *) + H.clear map; + argid := 0; + (* Make a copy of the fundec. *) + let f' = {f with svar = f.svar} in + let patchfunction (f' : fundec) = + (* Change the name. Only this late to allow the visitor to copy the + * svar *) + f'.svar.vname <- newname; + let findStmt (i: int) = + try H.find stmtmap i + with Not_found -> E.s (bug "Cannot find the copy of stmt#%d" i) + in + let patchstmt (s: stmt) = + match s.skind with + Goto (sr, l) -> + (* Make a copy of the reference *) + let sr' = ref (findStmt !sr.sid) in + s.skind <- Goto (sr',l) + | Switch (e, body, cases, l) -> + s.skind <- Switch (e, body, + List.map (fun cs -> findStmt cs.sid) cases, l) + | _ -> () + in + List.iter patchstmt !patches; + f' + in + patches := []; + sid := 0; + H.clear stmtmap; + ChangeDoChildrenPost (f', patchfunction) + + (* We must create a new varinfo for each declaration. Memoize to + * maintain sharing *) + method vvdec (v: varinfo) = + (* Some varinfo have empty names. Give them some name *) + if v.vname = "" then begin + v.vname <- "arg" ^ string_of_int !argid; incr argid + end; + try + ChangeTo (H.find map v.vname) + with Not_found -> begin + let v' = {v with vid = newVID () } in + H.add map v.vname v'; + ChangeDoChildrenPost (v', fun x -> x) + end + + (* We must replace references to local variables *) + method vvrbl (v: varinfo) = + if v.vglob then SkipChildren else + try + ChangeTo (H.find map v.vname) + with Not_found -> + E.s (bug "Cannot find the new copy of local variable %s" v.vname) + + + (* Replace statements. *) + method vstmt (s: stmt) : stmt visitAction = + s.sid <- !sid; incr sid; + let s' = {s with sid = s.sid} in + H.add stmtmap s.sid s'; (* Remember where we copied this *) + (* if we have a Goto or a Switch remember them to fixup at end *) + (match s'.skind with + (Goto _ | Switch _) -> patches := s' :: !patches + | _ -> ()); + (* Do the children *) + ChangeDoChildrenPost (s', fun x -> x) + + (* Copy blocks since they are mutable *) + method vblock (b: block) = + ChangeDoChildrenPost ({b with bstmts = b.bstmts}, fun x -> x) + + + method vglob _ = E.s (bug "copyFunction should not be used on globals") +end + +(* We need a function that copies a CIL function. *) +let copyFunction (f: fundec) (newname: string) : fundec = + visitCilFunction (new copyFunctionVisitor(newname)) f + +(********* Compute the CFG ********) +let sid_counter = ref 0 + +let new_sid () = + let id = !sid_counter in + incr sid_counter; + id + +let statements : stmt list ref = ref [] +(* Clear all info about the CFG in statements *) +class clear : cilVisitor = object + inherit nopCilVisitor + method vstmt s = begin + s.sid <- !sid_counter ; + incr sid_counter ; + statements := s :: !statements; + s.succs <- [] ; + s.preds <- [] ; + DoChildren + end + method vexpr _ = SkipChildren + method vtype _ = SkipChildren + method vinst _ = SkipChildren +end + +let link source dest = begin + if not (List.mem dest source.succs) then + source.succs <- dest :: source.succs ; + if not (List.mem source dest.preds) then + dest.preds <- source :: dest.preds +end +let trylink source dest_option = match dest_option with + None -> () +| Some(dest) -> link source dest + + +(** Cmopute the successors and predecessors of a block, given a fallthrough *) +let rec succpred_block b fallthrough = + let rec handle sl = match sl with + [] -> () + | [a] -> succpred_stmt a fallthrough + | hd :: ((next :: _) as tl) -> + succpred_stmt hd (Some next) ; + handle tl + in handle b.bstmts + + +and succpred_stmt s fallthrough = + match s.skind with + Instr _ -> trylink s fallthrough + | Return _ -> () + | Goto(dest,l) -> link s !dest + | Break _ + | Continue _ + | Switch _ -> + failwith "computeCFGInfo: cannot be called on functions with break, continue or switch statements. Use prepareCFG first to remove them." + + | If(e1,b1,b2,l) -> + (match b1.bstmts with + [] -> trylink s fallthrough + | hd :: tl -> (link s hd ; succpred_block b1 fallthrough )) ; + (match b2.bstmts with + [] -> trylink s fallthrough + | hd :: tl -> (link s hd ; succpred_block b2 fallthrough )) + +(* + | Loop(b,l,_,_) -> + begin match b.bstmts with + [] -> failwith "computeCFGInfo: empty loop" + | hd :: tl -> + link s hd ; + succpred_block b (Some(hd)) + end +*) + + | While (e, b, l) -> begin match b.bstmts with + | [] -> failwith "computeCFGInfo: empty loop" + | hd :: tl -> link s hd ; + succpred_block b (Some(hd)) + end + + | DoWhile (e, b, l) ->begin match b.bstmts with + | [] -> failwith "computeCFGInfo: empty loop" + | hd :: tl -> link s hd ; + succpred_block b (Some(hd)) + end + + | For (bInit, e, bIter, b, l) -> + (match bInit.bstmts with + | [] -> failwith "computeCFGInfo: empty loop" + | hd :: tl -> link s hd ; + succpred_block bInit (Some(hd))) ; + (match bIter.bstmts with + | [] -> failwith "computeCFGInfo: empty loop" + | hd :: tl -> link s hd ; + succpred_block bIter (Some(hd))) ; + (match b.bstmts with + | [] -> failwith "computeCFGInfo: empty loop" + | hd :: tl -> link s hd ; + succpred_block b (Some(hd))) ; + + | Block(b) -> begin match b.bstmts with + [] -> trylink s fallthrough + | hd :: tl -> link s hd ; + succpred_block b fallthrough + end + | TryExcept _ | TryFinally _ -> + failwith "computeCFGInfo: structured exception handling not implemented" + +(* [weimer] Sun May 5 12:25:24 PDT 2002 + * This code was pulled from ext/switch.ml because it looks like we really + * want it to be part of CIL. + * + * Here is the magic handling to + * (1) replace switch statements with if/goto + * (2) remove "break" + * (3) remove "default" + * (4) remove "continue" + *) +let is_case_label l = match l with + | Case _ | Default _ -> true + | _ -> false + +let switch_count = ref (-1) +let get_switch_count () = + switch_count := 1 + !switch_count ; + !switch_count + +let switch_label = ref (-1) + +let rec xform_switch_stmt s break_dest cont_dest label_index = begin + s.labels <- List.map (fun lab -> match lab with + Label _ -> lab + | Case(e,l) -> + let suffix = + match isInteger e with + | Some value -> + if value < Int64.zero then + "neg_" ^ Int64.to_string (Int64.neg value) + else + Int64.to_string value + | None -> + incr switch_label; + "exp_" ^ string_of_int !switch_label + in + let str = Pretty.sprint !lineLength + (Pretty.dprintf "switch_%d_%s" label_index suffix) in + (Label(str,l,false)) + | Default(l) -> (Label(Printf.sprintf + "switch_%d_default" label_index,l,false)) + ) s.labels ; + match s.skind with + | Instr _ | Return _ | Goto _ -> () + | Break(l) -> begin try + s.skind <- Goto(break_dest (),l) + with e -> + ignore (error "prepareCFG: break: %a@!" d_stmt s) ; + raise e + end + | Continue(l) -> begin try + s.skind <- Goto(cont_dest (),l) + with e -> + ignore (error "prepareCFG: continue: %a@!" d_stmt s) ; + raise e + end + | If(e,b1,b2,l) -> xform_switch_block b1 break_dest cont_dest label_index ; + xform_switch_block b2 break_dest cont_dest label_index + | Switch(e,b,sl,l) -> begin + (* change + * switch (se) { + * case 0: s0 ; + * case 1: s1 ; break; + * ... + * } + * + * into: + * + * if (se == 0) goto label_0; + * else if (se == 1) goto label_1; + * ... + * else if (0) { // body_block + * label_0: s0; + * label_1: s1; goto label_break; + * ... + * } else if (0) { // break_block + * label_break: ; // break_stmt + * } + *) + let i = get_switch_count () in + let break_stmt = mkStmt (Instr []) in + break_stmt.labels <- + [Label((Printf.sprintf "switch_%d_break" i),l,false)] ; + let break_block = mkBlock [ break_stmt ] in + let body_block = b in + let body_if_stmtkind = (If(zero,body_block,break_block,l)) in + + (* The default case, if present, must be used only if *all* + non-default cases fail [ISO/IEC 9899:1999, §6.8.4.2, ¶5]. As a + result, we sort the order in which we handle the labels (but not the + order in which we print out the statements, so fall-through still + works as expected). *) + let compare_choices s1 s2 = match s1.labels, s2.labels with + | (Default(_) :: _), _ -> 1 + | _, (Default(_) :: _) -> -1 + | _, _ -> 0 + in + + let rec handle_choices sl = match sl with + [] -> body_if_stmtkind + | stmt_hd :: stmt_tl -> begin + let rec handle_labels lab_list = begin + match lab_list with + [] -> handle_choices stmt_tl + | Case(ce,cl) :: lab_tl -> + let pred = BinOp(Eq,e,ce,intType) in + let then_block = mkBlock [ mkStmt (Goto(ref stmt_hd,cl)) ] in + let else_block = mkBlock [ mkStmt (handle_labels lab_tl) ] in + If(pred,then_block,else_block,cl) + | Default(dl) :: lab_tl -> + (* ww: before this was 'if (1) goto label', but as Ben points + out this might confuse someone down the line who doesn't have + special handling for if(1) into thinking that there are two + paths here. The simpler 'goto label' is what we want. *) + Block(mkBlock [ mkStmt (Goto(ref stmt_hd,dl)) ; + mkStmt (handle_labels lab_tl) ]) + | Label(_,_,_) :: lab_tl -> handle_labels lab_tl + end in + handle_labels stmt_hd.labels + end in + s.skind <- handle_choices (List.sort compare_choices sl) ; + xform_switch_block b (fun () -> ref break_stmt) cont_dest i + end +(* + | Loop(b,l,_,_) -> + let i = get_switch_count () in + let break_stmt = mkStmt (Instr []) in + break_stmt.labels <- + [Label((Printf.sprintf "while_%d_break" i),l,false)] ; + let cont_stmt = mkStmt (Instr []) in + cont_stmt.labels <- + [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; + b.bstmts <- cont_stmt :: b.bstmts ; + let this_stmt = mkStmt + (Loop(b,l,Some(cont_stmt),Some(break_stmt))) in + let break_dest () = ref break_stmt in + let cont_dest () = ref cont_stmt in + xform_switch_block b break_dest cont_dest label_index ; + break_stmt.succs <- s.succs ; + let new_block = mkBlock [ this_stmt ; break_stmt ] in + s.skind <- Block new_block +*) + | While (e, b, l) -> + let i = get_switch_count () in + let break_stmt = mkStmt (Instr []) in + break_stmt.labels <- + [Label((Printf.sprintf "while_%d_break" i),l,false)] ; + let cont_stmt = mkStmt (Instr []) in + cont_stmt.labels <- + [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; + b.bstmts <- cont_stmt :: b.bstmts ; + let this_stmt = mkStmt + (While(e,b,l)) in + let break_dest () = ref break_stmt in + let cont_dest () = ref cont_stmt in + xform_switch_block b break_dest cont_dest label_index ; + break_stmt.succs <- s.succs ; + let new_block = mkBlock [ this_stmt ; break_stmt ] in + s.skind <- Block new_block + + | DoWhile (e, b, l) -> + let i = get_switch_count () in + let break_stmt = mkStmt (Instr []) in + break_stmt.labels <- + [Label((Printf.sprintf "while_%d_break" i),l,false)] ; + let cont_stmt = mkStmt (Instr []) in + cont_stmt.labels <- + [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; + b.bstmts <- cont_stmt :: b.bstmts ; + let this_stmt = mkStmt + (DoWhile(e,b,l)) in + let break_dest () = ref break_stmt in + let cont_dest () = ref cont_stmt in + xform_switch_block b break_dest cont_dest label_index ; + break_stmt.succs <- s.succs ; + let new_block = mkBlock [ this_stmt ; break_stmt ] in + s.skind <- Block new_block + + | For (bInit, e, bIter , b, l) -> + let i = get_switch_count () in + let break_stmt = mkStmt (Instr []) in + break_stmt.labels <- + [Label((Printf.sprintf "while_%d_break" i),l,false)] ; + let cont_stmt = mkStmt (Instr []) in + cont_stmt.labels <- + [Label((Printf.sprintf "while_%d_continue" i),l,false)] ; + b.bstmts <- cont_stmt :: b.bstmts ; + let this_stmt = mkStmt + (For(bInit,e,bIter,b,l)) in + let break_dest () = ref break_stmt in + let cont_dest () = ref cont_stmt in + xform_switch_block b break_dest cont_dest label_index ; + break_stmt.succs <- s.succs ; + let new_block = mkBlock [ this_stmt ; break_stmt ] in + s.skind <- Block new_block + + + | Block(b) -> xform_switch_block b break_dest cont_dest label_index + + | TryExcept _ | TryFinally _ -> + failwith "xform_switch_statement: structured exception handling not implemented" + +end and xform_switch_block b break_dest cont_dest label_index = + try + let rec link_succs sl = match sl with + | [] -> () + | hd :: tl -> (if hd.succs = [] then hd.succs <- tl) ; link_succs tl + in + link_succs b.bstmts ; + List.iter (fun stmt -> + xform_switch_stmt stmt break_dest cont_dest label_index) b.bstmts ; + with e -> + List.iter (fun stmt -> ignore + (warn "prepareCFG: %a@!" d_stmt stmt)) b.bstmts ; + raise e + +(* prepare a function for computeCFGInfo by removing break, continue, + * default and switch statements/labels and replacing them with Ifs and + * Gotos. *) +let prepareCFG (fd : fundec) : unit = + xform_switch_block fd.sbody + (fun () -> failwith "prepareCFG: break with no enclosing loop") + (fun () -> failwith "prepareCFG: continue with no enclosing loop") (-1) + +(* make the cfg and return a list of statements *) +let computeCFGInfo (f : fundec) (global_numbering : bool) : unit = + if not global_numbering then + sid_counter := 0 ; + statements := []; + let clear_it = new clear in + ignore (visitCilBlock clear_it f.sbody) ; + f.smaxstmtid <- Some (!sid_counter) ; + succpred_block f.sbody (None); + let res = List.rev !statements in + statements := []; + f.sallstmts <- res; + () + +let initCIL () = + if not !initCIL_called then begin + (* Set the machine *) + theMachine := if !msvcMode then M.msvc else M.gcc; + (* Pick type for string literals *) + stringLiteralType := if !theMachine.M.const_string_literals then + charConstPtrType + else + charPtrType; + (* Find the right ikind given the size *) + let findIkind (unsigned: bool) (sz: int) : ikind = + (* Test the most common sizes first *) + if sz = !theMachine.M.sizeof_int then + if unsigned then IUInt else IInt + else if sz = !theMachine.M.sizeof_long then + if unsigned then IULong else ILong + else if sz = 1 then + if unsigned then IUChar else IChar + else if sz = !theMachine.M.sizeof_short then + if unsigned then IUShort else IShort + else if sz = !theMachine.M.sizeof_longlong then + if unsigned then IULongLong else ILongLong + else + E.s(E.unimp "initCIL: cannot find the right ikind for size %d\n" sz) + in + upointType := TInt(findIkind true !theMachine.M.sizeof_ptr, []); + kindOfSizeOf := findIkind true !theMachine.M.sizeof_sizeof; + typeOfSizeOf := TInt(!kindOfSizeOf, []); + H.add gccBuiltins "__builtin_memset" + (voidPtrType, [ voidPtrType; intType; intType ], false); + wcharKind := findIkind false !theMachine.M.sizeof_wchar; + wcharType := TInt(!wcharKind, []); + char_is_unsigned := !theMachine.M.char_is_unsigned; + little_endian := !theMachine.M.little_endian; + underscore_name := !theMachine.M.underscore_name; + nextGlobalVID := 1; + nextCompinfoKey := 1; + initCIL_called := true + end + + +(* We want to bring all type declarations before the data declarations. This + * is needed for code of the following form: + + int f(); // Prototype without arguments + typedef int FOO; + int f(FOO x) { ... } + + In CIL the prototype also lists the type of the argument as being FOO, + which is undefined. + + There is one catch with this scheme. If the type contains an array whose + length refers to variables then those variables must be declared before + the type *) + +let pullTypesForward = true + + + (* Scan a type and collect the variables that are refered *) +class getVarsInGlobalClass (pacc: varinfo list ref) = object + inherit nopCilVisitor + method vvrbl (vi: varinfo) = + pacc := vi :: !pacc; + SkipChildren + + method vglob = function + GType _ | GCompTag _ -> DoChildren + | _ -> SkipChildren + +end + +let getVarsInGlobal (g : global) : varinfo list = + let pacc : varinfo list ref = ref [] in + let v : cilVisitor = new getVarsInGlobalClass pacc in + ignore (visitCilGlobal v g); + !pacc + +let hasPrefix p s = + let pl = String.length p in + (String.length s >= pl) && String.sub s 0 pl = p + +let pushGlobal (g: global) + ~(types:global list ref) + ~(variables: global list ref) = + if not pullTypesForward then + variables := g :: !variables + else + begin + (* Collect a list of variables that are refered from the type. Return + * Some if the global should go with the types and None if it should go + * to the variables. *) + let varsintype : (varinfo list * location) option = + match g with + GType (_, l) | GCompTag (_, l) -> Some (getVarsInGlobal g, l) + | GEnumTag (_, l) | GPragma (Attr("pack", _), l) + | GCompTagDecl (_, l) | GEnumTagDecl (_, l) -> Some ([], l) + (** Move the warning pragmas early + | GPragma(Attr(s, _), l) when hasPrefix "warning" s -> Some ([], l) + *) + | _ -> None (* Does not go with the types *) + in + match varsintype with + None -> variables := g :: !variables + | Some (vl, loc) -> + types := + (* insert declarations for referred variables ('vl'), before + * the type definition 'g' itself *) + g :: (List.fold_left (fun acc v -> GVarDecl(v, loc) :: acc) + !types vl) + end + + +type formatArg = + Fe of exp + | Feo of exp option (** For array lengths *) + | Fu of unop + | Fb of binop + | Fk of ikind + | FE of exp list (** For arguments in a function call *) + | Ff of (string * typ * attributes) (** For a formal argument *) + | FF of (string * typ * attributes) list (* For formal argument lists *) + | Fva of bool (** For the ellipsis in a function type *) + | Fv of varinfo + | Fl of lval + | Flo of lval option (** For the result of a function call *) + | Fo of offset + | Fc of compinfo + | Fi of instr + | FI of instr list + | Ft of typ + | Fd of int + | Fg of string + | Fs of stmt + | FS of stmt list + | FA of attributes + + | Fp of attrparam + | FP of attrparam list + + | FX of string + +let d_formatarg () = function + Fe e -> dprintf "Fe(%a)" d_exp e + | Feo None -> dprintf "Feo(None)" + | Feo (Some e) -> dprintf "Feo(%a)" d_exp e + | FE _ -> dprintf "FE()" + | Fk ik -> dprintf "Fk()" + | Fva b -> dprintf "Fva(%b)" b + | Ff (an, _, _) -> dprintf "Ff(%s)" an + | FF _ -> dprintf "FF(...)" + | FA _ -> dprintf "FA(...)" + | Fu uo -> dprintf "Fu()" + | Fb bo -> dprintf "Fb()" + | Fv v -> dprintf "Fv(%s)" v.vname + | Fl l -> dprintf "Fl(%a)" d_lval l + | Flo None -> dprintf "Flo(None)" + | Flo (Some l) -> dprintf "Flo(%a)" d_lval l + | Fo o -> dprintf "Fo" + | Fc ci -> dprintf "Fc(%s)" ci.cname + | Fi i -> dprintf "Fi(...)" + | FI i -> dprintf "FI(...)" + | Ft t -> dprintf "Ft(%a)" d_type t + | Fd n -> dprintf "Fd(%d)" n + | Fg s -> dprintf "Fg(%s)" s + | Fp _ -> dprintf "Fp(...)" + | FP n -> dprintf "FP(...)" + | Fs _ -> dprintf "FS" + | FS _ -> dprintf "FS" + + | FX _ -> dprintf "FX()" + + diff --git a/cil/src/cil.mli b/cil/src/cil.mli new file mode 100644 index 0000000..31c4e65 --- /dev/null +++ b/cil/src/cil.mli @@ -0,0 +1,2455 @@ +(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) + +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* + * CIL: An intermediate language for analyzing C programs. + * + * George Necula + * + *) + +(** CIL API Documentation. An html version of this document can be found at + * http://manju.cs.berkeley.edu/cil. *) + +(** Call this function to perform some initialization. Call if after you have + * set {!Cil.msvcMode}. *) +val initCIL: unit -> unit + + +(** This are the CIL version numbers. A CIL version is a number of the form + * M.m.r (major, minor and release) *) +val cilVersion: string +val cilVersionMajor: int +val cilVersionMinor: int +val cilVersionRevision: int + +(** This module defines the abstract syntax of CIL. It also provides utility + * functions for traversing the CIL data structures, and pretty-printing + * them. The parser for both the GCC and MSVC front-ends can be invoked as + * [Frontc.parse: string -> unit ->] {!Cil.file}. This function must be given + * the name of a preprocessed C file and will return the top-level data + * structure that describes a whole source file. By default the parsing and + * elaboration into CIL is done as for GCC source. If you want to use MSVC + * source you must set the {!Cil.msvcMode} to [true] and must also invoke the + * function [Frontc.setMSVCMode: unit -> unit]. *) + + +(** {b The Abstract Syntax of CIL} *) + + +(** The top-level representation of a CIL source file (and the result of the + * parsing and elaboration). Its main contents is the list of global + * declarations and definitions. You can iterate over the globals in a + * {!Cil.file} using the following iterators: {!Cil.mapGlobals}, + * {!Cil.iterGlobals} and {!Cil.foldGlobals}. You can also use the + * {!Cil.dummyFile} when you need a {!Cil.file} as a placeholder. For each + * global item CIL stores the source location where it appears (using the + * type {!Cil.location}) *) + +type file = + { mutable fileName: string; (** The complete file name *) + mutable globals: global list; (** List of globals as they will appear + in the printed file *) + mutable globinit: fundec option; + (** An optional global initializer function. This is a function where + * you can put stuff that must be executed before the program is + * started. This function, is conceptually at the end of the file, + * although it is not part of the globals list. Use {!Cil.getGlobInit} + * to create/get one. *) + mutable globinitcalled: bool; + (** Whether the global initialization function is called in main. This + * should always be false if there is no global initializer. When you + * create a global initialization CIL will try to insert code in main + * to call it. This will not happen if your file does not contain a + * function called "main" *) + } +(** Top-level representation of a C source file *) + +and comment = location * string + +(** {b Globals}. The main type for representing global declarations and + * definitions. A list of these form a CIL file. The order of globals in the + * file is generally important. *) + +(** A global declaration or definition *) +and global = + | GType of typeinfo * location + (** A typedef. All uses of type names (through the [TNamed] constructor) + must be preceded in the file by a definition of the name. The string + is the defined name and always not-empty. *) + + | GCompTag of compinfo * location + (** Defines a struct/union tag with some fields. There must be one of + these for each struct/union tag that you use (through the [TComp] + constructor) since this is the only context in which the fields are + printed. Consequently nested structure tag definitions must be + broken into individual definitions with the innermost structure + defined first. *) + + | GCompTagDecl of compinfo * location + (** Declares a struct/union tag. Use as a forward declaration. This is + * printed without the fields. *) + + | GEnumTag of enuminfo * location + (** Declares an enumeration tag with some fields. There must be one of + these for each enumeration tag that you use (through the [TEnum] + constructor) since this is the only context in which the items are + printed. *) + + | GEnumTagDecl of enuminfo * location + (** Declares an enumeration tag. Use as a forward declaration. This is + * printed without the items. *) + + | GVarDecl of varinfo * location + (** A variable declaration (not a definition). If the variable has a + function type then this is a prototype. There can be several + declarations and at most one definition for a given variable. If both + forms appear then they must share the same varinfo structure. A + prototype shares the varinfo with the fundec of the definition. Either + has storage Extern or there must be a definition in this file *) + + | GVar of varinfo * initinfo * location + (** A variable definition. Can have an initializer. The initializer is + * updateable so that you can change it without requiring to recreate + * the list of globals. There can be at most one definition for a + * variable in an entire program. Cannot have storage Extern or function + * type. *) + + | GFun of fundec * location + (** A function definition. *) + + | GAsm of string * location (** Global asm statement. These ones + can contain only a template *) + | GPragma of attribute * location (** Pragmas at top level. Use the same + syntax as attributes *) + | GText of string (** Some text (printed verbatim) at + top level. E.g., this way you can + put comments in the output. *) + +(** {b Types}. A C type is represented in CIL using the type {!Cil.typ}. + * Among types we differentiate the integral types (with different kinds + * denoting the sign and precision), floating point types, enumeration types, + * array and pointer types, and function types. Every type is associated with + * a list of attributes, which are always kept in sorted order. Use + * {!Cil.addAttribute} and {!Cil.addAttributes} to construct list of + * attributes. If you want to inspect a type, you should use + * {!Cil.unrollType} or {!Cil.unrollTypeDeep} to see through the uses of + * named types. *) +(** CIL is configured at build-time with the sizes and alignments of the + * underlying compiler (GCC or MSVC). CIL contains functions that can compute + * the size of a type (in bits) {!Cil.bitsSizeOf}, the alignment of a type + * (in bytes) {!Cil.alignOf_int}, and can convert an offset into a start and + * width (both in bits) using the function {!Cil.bitsOffset}. At the moment + * these functions do not take into account the [packed] attributes and + * pragmas. *) + +and typ = + TVoid of attributes (** Void type. Also predefined as {!Cil.voidType} *) + | TInt of ikind * attributes + (** An integer type. The kind specifies the sign and width. Several + * useful variants are predefined as {!Cil.intType}, {!Cil.uintType}, + * {!Cil.longType}, {!Cil.charType}. *) + + + | TFloat of fkind * attributes + (** A floating-point type. The kind specifies the precision. You can + * also use the predefined constant {!Cil.doubleType}. *) + + | TPtr of typ * attributes + (** Pointer type. Several useful variants are predefined as + * {!Cil.charPtrType}, {!Cil.charConstPtrType} (pointer to a + * constant character), {!Cil.voidPtrType}, + * {!Cil.intPtrType} *) + + | TArray of typ * exp option * attributes + (** Array type. It indicates the base type and the array length. *) + + | TFun of typ * (string * typ * attributes) list option * bool * attributes + (** Function type. Indicates the type of the result, the name, type + * and name attributes of the formal arguments ([None] if no + * arguments were specified, as in a function whose definition or + * prototype we have not seen; [Some \[\]] means void). Use + * {!Cil.argsToList} to obtain a list of arguments. The boolean + * indicates if it is a variable-argument function. If this is the + * type of a varinfo for which we have a function declaration then + * the information for the formals must match that in the + * function's sformals. Use {!Cil.setFormals}, or + * {!Cil.setFunctionType}, or {!Cil.makeFormalVar} for this + * purpose. *) + + | TNamed of typeinfo * attributes + (* The use of a named type. Each such type name must be preceded + * in the file by a [GType] global. This is printed as just the + * type name. The actual referred type is not printed here and is + * carried only to simplify processing. To see through a sequence + * of named type references, use {!Cil.unrollType} or + * {!Cil.unrollTypeDeep}. The attributes are in addition to those + * given when the type name was defined. *) + + | TComp of compinfo * attributes +(** The most delicate issue for C types is that recursion that is possible by + * using structures and pointers. To address this issue we have a more + * complex representation for structured types (struct and union). Each such + * type is represented using the {!Cil.compinfo} type. For each composite + * type the {!Cil.compinfo} structure must be declared at top level using + * [GCompTag] and all references to it must share the same copy of the + * structure. The attributes given are those pertaining to this use of the + * type and are in addition to the attributes that were given at the + * definition of the type and which are stored in the {!Cil.compinfo}. *) + + | TEnum of enuminfo * attributes + (** A reference to an enumeration type. All such references must + share the enuminfo among them and with a [GEnumTag] global that + precedes all uses. The attributes refer to this use of the + enumeration and are in addition to the attributes of the + enumeration itself, which are stored inside the enuminfo *) + + + | TBuiltin_va_list of attributes + (** This is the same as the gcc's type with the same name *) + +(** + There are a number of functions for querying the kind of a type. These are + {!Cil.isIntegralType}, + {!Cil.isArithmeticType}, + {!Cil.isPointerType}, + {!Cil.isFunctionType}, + {!Cil.isArrayType}. + + There are two easy ways to scan a type. First, you can use the +{!Cil.existsType} to return a boolean answer about a type. This function +is controlled by a user-provided function that is queried for each type that is +used to construct the current type. The function can specify whether to +terminate the scan with a boolean result or to continue the scan for the +nested types. + + The other method for scanning types is provided by the visitor interface (see + {!Cil.cilVisitor}). + + If you want to compare types (or to use them as hash-values) then you should +use instead type signatures (represented as {!Cil.typsig}). These +contain the same information as types but canonicalized such that simple Ocaml +structural equality will tell whether two types are equal. Use +{!Cil.typeSig} to compute the signature of a type. If you want to ignore +certain type attributes then use {!Cil.typeSigWithAttrs}. + +*) + + +(** Various kinds of integers *) +and ikind = + IChar (** [char] *) + | ISChar (** [signed char] *) + | IUChar (** [unsigned char] *) + | IInt (** [int] *) + | IUInt (** [unsigned int] *) + | IShort (** [short] *) + | IUShort (** [unsigned short] *) + | ILong (** [long] *) + | IULong (** [unsigned long] *) + | ILongLong (** [long long] (or [_int64] on Microsoft Visual C) *) + | IULongLong (** [unsigned long long] (or [unsigned _int64] on Microsoft + Visual C) *) + +(** Various kinds of floating-point numbers*) +and fkind = + FFloat (** [float] *) + | FDouble (** [double] *) + | FLongDouble (** [long double] *) + + +(** {b Attributes.} *) + +and attribute = Attr of string * attrparam list +(** An attribute has a name and some optional parameters. The name should not + * start or end with underscore. When CIL parses attribute names it will + * strip leading and ending underscores (to ensure that the multitude of GCC + * attributes such as const, __const and __const__ all mean the same thing.) *) + +(** Attributes are lists sorted by the attribute name. Use the functions + * {!Cil.addAttribute} and {!Cil.addAttributes} to insert attributes in an + * attribute list and maintain the sortedness. *) +and attributes = attribute list + +(** The type of parameters of attributes *) +and attrparam = + | AInt of int (** An integer constant *) + | AStr of string (** A string constant *) + | ACons of string * attrparam list (** Constructed attributes. These + are printed [foo(a1,a2,...,an)]. + The list of parameters can be + empty and in that case the + parentheses are not printed. *) + | ASizeOf of typ (** A way to talk about types *) + | ASizeOfE of attrparam + | ASizeOfS of typsig (** Replacement for ASizeOf in type + signatures. Only used for + attributes inside typsigs.*) + | AAlignOf of typ + | AAlignOfE of attrparam + | AAlignOfS of typsig + | AUnOp of unop * attrparam + | ABinOp of binop * attrparam * attrparam + | ADot of attrparam * string (** a.foo **) + +(** {b Structures.} The {!Cil.compinfo} describes the definition of a + * structure or union type. Each such {!Cil.compinfo} must be defined at the + * top-level using the [GCompTag] constructor and must be shared by all + * references to this type (using either the [TComp] type constructor or from + * the definition of the fields. + + If all you need is to scan the definition of each + * composite type once, you can do that by scanning all top-level [GCompTag]. + + * Constructing a {!Cil.compinfo} can be tricky since it must contain fields + * that might refer to the host {!Cil.compinfo} and furthermore the type of + * the field might need to refer to the {!Cil.compinfo} for recursive types. + * Use the {!Cil.mkCompInfo} function to create a {!Cil.compinfo}. You can + * easily fetch the {!Cil.fieldinfo} for a given field in a structure with + * {!Cil.getCompField}. *) + +(** The definition of a structure or union type. Use {!Cil.mkCompInfo} to + * make one and use {!Cil.copyCompInfo} to copy one (this ensures that a new + * key is assigned and that the fields have the right pointers to parents.). *) +and compinfo = { + mutable cstruct: bool; + (** True if struct, False if union *) + mutable cname: string; + (** The name. Always non-empty. Use {!Cil.compFullName} to get the full + * name of a comp (along with the struct or union) *) + mutable ckey: int; + (** A unique integer. This is assigned by {!Cil.mkCompInfo} using a + * global variable in the Cil module. Thus two identical structs in two + * different files might have different keys. Use {!Cil.copyCompInfo} to + * copy structures so that a new key is assigned. *) + mutable cfields: fieldinfo list; + (** Information about the fields. Notice that each fieldinfo has a + * pointer back to the host compinfo. This means that you should not + * share fieldinfo's between two compinfo's *) + mutable cattr: attributes; + (** The attributes that are defined at the same time as the composite + * type. These attributes can be supplemented individually at each + * reference to this [compinfo] using the [TComp] type constructor. *) + mutable cdefined: bool; + (** This boolean flag can be used to distinguish between structures + that have not been defined and those that have been defined but have + no fields (such things are allowed in gcc). *) + mutable creferenced: bool; + (** True if used. Initially set to false. *) + } + +(** {b Structure fields.} The {!Cil.fieldinfo} structure is used to describe + * a structure or union field. Fields, just like variables, can have + * attributes associated with the field itself or associated with the type of + * the field (stored along with the type of the field). *) + +(** Information about a struct/union field *) +and fieldinfo = { + mutable fcomp: compinfo; + (** The host structure that contains this field. There can be only one + * [compinfo] that contains the field. *) + mutable fname: string; + (** The name of the field. Might be the value of {!Cil.missingFieldName} + * in which case it must be a bitfield and is not printed and it does not + * participate in initialization *) + mutable ftype: typ; + (** The type *) + mutable fbitfield: int option; + (** If a bitfield then ftype should be an integer type and the width of + * the bitfield must be 0 or a positive integer smaller or equal to the + * width of the integer type. A field of width 0 is used in C to control + * the alignment of fields. *) + mutable fattr: attributes; + (** The attributes for this field (not for its type) *) + mutable floc: location; + (** The location where this field is defined *) +} + + + +(** {b Enumerations.} Information about an enumeration. This is shared by all + * references to an enumeration. Make sure you have a [GEnumTag] for each of + * of these. *) + +(** Information about an enumeration *) +and enuminfo = { + mutable ename: string; + (** The name. Always non-empty. *) + mutable eitems: (string * exp * location) list; + (** Items with names and values. This list should be non-empty. The item + * values must be compile-time constants. *) + mutable eattr: attributes; + (** The attributes that are defined at the same time as the enumeration + * type. These attributes can be supplemented individually at each + * reference to this [enuminfo] using the [TEnum] type constructor. *) + mutable ereferenced: bool; + (** True if used. Initially set to false*) +} + +(** {b Enumerations.} Information about an enumeration. This is shared by all + * references to an enumeration. Make sure you have a [GEnumTag] for each of + * of these. *) + +(** Information about a defined type *) +and typeinfo = { + mutable tname: string; + (** The name. Can be empty only in a [GType] when introducing a composite + * or enumeration tag. If empty cannot be referred to from the file *) + mutable ttype: typ; + (** The actual type. This includes the attributes that were present in + * the typedef *) + mutable treferenced: bool; + (** True if used. Initially set to false*) +} + +(** {b Variables.} + Each local or global variable is represented by a unique {!Cil.varinfo} +structure. A global {!Cil.varinfo} can be introduced with the [GVarDecl] or +[GVar] or [GFun] globals. A local varinfo can be introduced as part of a +function definition {!Cil.fundec}. + + All references to a given global or local variable must refer to the same +copy of the [varinfo]. Each [varinfo] has a globally unique identifier that +can be used to index maps and hashtables (the name can also be used for this +purpose, except for locals from different functions). This identifier is +constructor using a global counter. + + It is very important that you construct [varinfo] structures using only one + of the following functions: +- {!Cil.makeGlobalVar} : to make a global variable +- {!Cil.makeTempVar} : to make a temporary local variable whose name +will be generated so that to avoid conflict with other locals. +- {!Cil.makeLocalVar} : like {!Cil.makeTempVar} but you can specify the +exact name to be used. +- {!Cil.copyVarinfo}: make a shallow copy of a varinfo assigning a new name +and a new unique identifier + + A [varinfo] is also used in a function type to denote the list of formals. + +*) + +(** Information about a variable. *) +and varinfo = { + mutable vname: string; + (** The name of the variable. Cannot be empty. It is primarily your + * responsibility to ensure the uniqueness of a variable name. For local + * variables {!Cil.makeTempVar} helps you ensure that the name is unique. + *) + + mutable vtype: typ; + (** The declared type of the variable. *) + + mutable vattr: attributes; + (** A list of attributes associated with the variable.*) + mutable vstorage: storage; + (** The storage-class *) + + mutable vglob: bool; + (** True if this is a global variable*) + + mutable vinline: bool; + (** Whether this varinfo is for an inline function. *) + + mutable vdecl: location; + (** Location of variable declaration. *) + + mutable vid: int; + (** A unique integer identifier. This field will be + * set for you if you use one of the {!Cil.makeFormalVar}, + * {!Cil.makeLocalVar}, {!Cil.makeTempVar}, {!Cil.makeGlobalVar}, or + * {!Cil.copyVarinfo}. *) + + mutable vaddrof: bool; + (** True if the address of this variable is taken. CIL will set these + * flags when it parses C, but you should make sure to set the flag + * whenever your transformation create [AddrOf] expression. *) + + mutable vreferenced: bool; + (** True if this variable is ever referenced. This is computed by + * [removeUnusedVars]. It is safe to just initialize this to False *) +} + +(** Storage-class information *) +and storage = + NoStorage (** The default storage. Nothing is printed *) + | Static + | Register + | Extern + + +(** {b Expressions.} The CIL expression language contains only the side-effect free expressions of +C. They are represented as the type {!Cil.exp}. There are several +interesting aspects of CIL expressions: + + Integer and floating point constants can carry their textual representation. +This way the integer 15 can be printed as 0xF if that is how it occurred in the +source. + + CIL uses 64 bits to represent the integer constants and also stores the width +of the integer type. Care must be taken to ensure that the constant is +representable with the given width. Use the functions {!Cil.kinteger}, +{!Cil.kinteger64} and {!Cil.integer} to construct constant +expressions. CIL predefines the constants {!Cil.zero}, +{!Cil.one} and {!Cil.mone} (for -1). + + Use the functions {!Cil.isConstant} and {!Cil.isInteger} to test if +an expression is a constant and a constant integer respectively. + + CIL keeps the type of all unary and binary expressions. You can think of that +type qualifying the operator. Furthermore there are different operators for +arithmetic and comparisons on arithmetic types and on pointers. + + Another unusual aspect of CIL is that the implicit conversion between an +expression of array type and one of pointer type is made explicit, using the +[StartOf] expression constructor (which is not printed). If you apply the +[AddrOf}]constructor to an lvalue of type [T] then you will be getting an +expression of type [TPtr(T)]. + + You can find the type of an expression with {!Cil.typeOf}. + + You can perform constant folding on expressions using the function +{!Cil.constFold}. +*) + +(** Expressions (Side-effect free)*) +and exp = + Const of constant (** Constant *) + | Lval of lval (** Lvalue *) + | SizeOf of typ + (** sizeof(). Has [unsigned int] type (ISO 6.5.3.4). This is not + * turned into a constant because some transformations might want to + * change types *) + + | SizeOfE of exp + (** sizeof() *) + + | SizeOfStr of string + (** sizeof(string_literal). We separate this case out because this is the + * only instance in which a string literal should not be treated as + * having type pointer to character. *) + + | AlignOf of typ + (** This corresponds to the GCC __alignof_. Has [unsigned int] type *) + | AlignOfE of exp + + + | UnOp of unop * exp * typ + (** Unary operation. Includes the type of the result. *) + + | BinOp of binop * exp * exp * typ + (** Binary operation. Includes the type of the result. The arithmetic + * conversions are made explicit for the arguments. *) + + | CastE of typ * exp + (** Use {!Cil.mkCast} to make casts. *) + + | AddrOf of lval + (** Always use {!Cil.mkAddrOf} to construct one of these. Apply to an + * lvalue of type [T] yields an expression of type [TPtr(T)] *) + + | StartOf of lval + (** Conversion from an array to a pointer to the beginning of the array. + * Given an lval of type [TArray(T)] produces an expression of type + * [TPtr(T)]. In C this operation is implicit, the [StartOf] operator is + * not printed. We have it in CIL because it makes the typing rules + * simpler. *) + +(** {b Constants.} *) + +(** Literal constants *) +and constant = + | CInt64 of int64 * ikind * string option + (** Integer constant. Give the ikind (see ISO9899 6.1.3.2) and the + * textual representation, if available. (This allows us to print a + * constant as, for example, 0xF instead of 15.) Use {!Cil.integer} or + * {!Cil.kinteger} to create these. Watch out for integers that cannot be + * represented on 64 bits. OCAML does not give Overflow exceptions. *) + | CStr of string + (* String constant. The escape characters inside the string have been + * already interpreted. This constant has pointer to character type! The + * only case when you would like a string literal to have an array type + * is when it is an argument to sizeof. In that case you should use + * SizeOfStr. *) + | CWStr of int64 list + (* Wide character string constant. Note that the local interpretation + * of such a literal depends on {!Cil.wcharType} and {!Cil.wcharKind}. + * Such a constant has type pointer to {!Cil.wcharType}. The + * escape characters in the string have not been "interpreted" in + * the sense that L"A\xabcd" remains "A\xabcd" rather than being + * represented as the wide character list with two elements: 65 and + * 43981. That "interpretation" depends on the underlying wide + * character type. *) + | CChr of char + (** Character constant. This has type int, so use charConstToInt + * to read the value in case sign-extension is needed. *) + | CReal of float * fkind * string option + (** Floating point constant. Give the fkind (see ISO 6.4.4.2) and also + * the textual representation, if available. *) + | CEnum of exp * string * enuminfo + (** An enumeration constant with the given value, name, from the given + * enuminfo. This is used only if {!Cil.lowerConstants} is true + * (default). Use {!Cil.constFoldVisitor} to replace these with integer + * constants. *) + +(** Unary operators *) +and unop = + Neg (** Unary minus *) + | BNot (** Bitwise complement (~) *) + | LNot (** Logical Not (!) *) + +(** Binary operations *) +and binop = + PlusA (** arithmetic + *) + | PlusPI (** pointer + integer *) + | IndexPI (** pointer + integer but only when + * it arises from an expression + * [e\[i\]] when [e] is a pointer and + * not an array. This is semantically + * the same as PlusPI but CCured uses + * this as a hint that the integer is + * probably positive. *) + | MinusA (** arithmetic - *) + | MinusPI (** pointer - integer *) + | MinusPP (** pointer - pointer *) + | Mult (** * *) + | Div (** / *) + | Mod (** % *) + | Shiftlt (** shift left *) + | Shiftrt (** shift right *) + + | Lt (** < (arithmetic comparison) *) + | Gt (** > (arithmetic comparison) *) + | Le (** <= (arithmetic comparison) *) + | Ge (** > (arithmetic comparison) *) + | Eq (** == (arithmetic comparison) *) + | Ne (** != (arithmetic comparison) *) + | BAnd (** bitwise and *) + | BXor (** exclusive-or *) + | BOr (** inclusive-or *) + + | LAnd (** logical and. Unlike other + * expressions this one does not + * always evaluate both operands. If + * you want to use these, you must + * set {!Cil.useLogicalOperators}. *) + | LOr (** logical or. Unlike other + * expressions this one does not + * always evaluate both operands. If + * you want to use these, you must + * set {!Cil.useLogicalOperators}. *) + +(** {b Lvalues.} Lvalues are the sublanguage of expressions that can appear at the left of an assignment or as operand to the address-of operator. +In C the syntax for lvalues is not always a good indication of the meaning +of the lvalue. For example the C value +{v +a[0][1][2] + v} + might involve 1, 2 or 3 memory reads when used in an expression context, +depending on the declared type of the variable [a]. If [a] has type [int +\[4\]\[4\]\[4\]] then we have one memory read from somewhere inside the area +that stores the array [a]. On the other hand if [a] has type [int ***] then +the expression really means [* ( * ( * (a + 0) + 1) + 2)], in which case it is +clear that it involves three separate memory operations. + +An lvalue denotes the contents of a range of memory addresses. This range +is denoted as a host object along with an offset within the object. The +host object can be of two kinds: a local or global variable, or an object +whose address is in a pointer expression. We distinguish the two cases so +that we can tell quickly whether we are accessing some component of a +variable directly or we are accessing a memory location through a pointer. +To make it easy to +tell what an lvalue means CIL represents lvalues as a host object and an +offset (see {!Cil.lval}). The host object (represented as +{!Cil.lhost}) can be a local or global variable or can be the object +pointed-to by a pointer expression. The offset (represented as +{!Cil.offset}) is a sequence of field or array index designators. + + Both the typing rules and the meaning of an lvalue is very precisely +specified in CIL. + + The following are a few useful function for operating on lvalues: +- {!Cil.mkMem} - makes an lvalue of [Mem] kind. Use this to ensure +that certain equivalent forms of lvalues are canonized. +For example, [*&x = x]. +- {!Cil.typeOfLval} - the type of an lvalue +- {!Cil.typeOffset} - the type of an offset, given the type of the +host. +- {!Cil.addOffset} and {!Cil.addOffsetLval} - extend sequences +of offsets. +- {!Cil.removeOffset} and {!Cil.removeOffsetLval} - shrink sequences +of offsets. + +The following equivalences hold {v +Mem(AddrOf(Mem a, aoff)), off = Mem a, aoff + off +Mem(AddrOf(Var v, aoff)), off = Var v, aoff + off +AddrOf (Mem a, NoOffset) = a + v} + +*) +(** An lvalue *) +and lval = + lhost * offset + +(** The host part of an {!Cil.lval}. *) +and lhost = + | Var of varinfo + (** The host is a variable. *) + + | Mem of exp + (** The host is an object of type [T] when the expression has pointer + * [TPtr(T)]. *) + + +(** The offset part of an {!Cil.lval}. Each offset can be applied to certain + * kinds of lvalues and its effect is that it advances the starting address + * of the lvalue and changes the denoted type, essentially focusing to some + * smaller lvalue that is contained in the original one. *) +and offset = + | NoOffset (** No offset. Can be applied to any lvalue and does + * not change either the starting address or the type. + * This is used when the lval consists of just a host + * or as a terminator in a list of other kinds of + * offsets. *) + + | Field of fieldinfo * offset + (** A field offset. Can be applied only to an lvalue + * that denotes a structure or a union that contains + * the mentioned field. This advances the offset to the + * beginning of the mentioned field and changes the + * type to the type of the mentioned field. *) + + | Index of exp * offset + (** An array index offset. Can be applied only to an + * lvalue that denotes an array. This advances the + * starting address of the lval to the beginning of the + * mentioned array element and changes the denoted type + * to be the type of the array element *) + + +(** {b Initializers.} +A special kind of expressions are those that can appear as initializers for +global variables (initialization of local variables is turned into +assignments). The initializers are represented as type {!Cil.init}. You +can create initializers with {!Cil.makeZeroInit} and you can conveniently +scan compound initializers them with {!Cil.foldLeftCompound} or with {!Cil.foldLeftCompoundAll}. +*) +(** Initializers for global variables. *) +and init = + | SingleInit of exp (** A single initializer *) + | CompoundInit of typ * (offset * init) list + (** Used only for initializers of structures, unions and arrays. The + * offsets are all of the form [Field(f, NoOffset)] or [Index(i, + * NoOffset)] and specify the field or the index being initialized. For + * structures all fields must have an initializer (except the unnamed + * bitfields), in the proper order. This is necessary since the offsets + * are not printed. For unions there must be exactly one initializer. If + * the initializer is not for the first field then a field designator is + * printed, so you better be on GCC since MSVC does not understand this. + * For arrays, however, we allow you to give only a prefix of the + * initializers. You can scan an initializer list with + * {!Cil.foldLeftCompound} or with {!Cil.foldLeftCompoundAll}. *) + + +(** We want to be able to update an initializer in a global variable, so we + * define it as a mutable field *) +and initinfo = { + mutable init : init option; + } + +(** {b Function definitions.} +A function definition is always introduced with a [GFun] constructor at the +top level. All the information about the function is stored into a +{!Cil.fundec}. Some of the information (e.g. its name, type, +storage, attributes) is stored as a {!Cil.varinfo} that is a field of the +[fundec]. To refer to the function from the expression language you must use +the [varinfo]. + + The function definition contains, in addition to the body, a list of all the +local variables and separately a list of the formals. Both kind of variables +can be referred to in the body of the function. The formals must also be shared +with the formals that appear in the function type. For that reason, to +manipulate formals you should use the provided functions +{!Cil.makeFormalVar} and {!Cil.setFormals} and {!Cil.makeFormalVar}. +*) +(** Function definitions. *) +and fundec = + { mutable svar: varinfo; + (** Holds the name and type as a variable, so we can refer to it + * easily from the program. All references to this function either + * in a function call or in a prototype must point to the same + * [varinfo]. *) + mutable sformals: varinfo list; + (** Formals. These must be in the same order and with the same + * information as the formal information in the type of the function. + * Use {!Cil.setFormals} or + * {!Cil.setFunctionType} or {!Cil.makeFormalVar} + * to set these formals and ensure that they + * are reflected in the function type. Do not make copies of these + * because the body refers to them. *) + mutable slocals: varinfo list; + (** Locals. Does NOT include the sformals. Do not make copies of + * these because the body refers to them. *) + mutable smaxid: int; (** Max local id. Starts at 0. Used for + * creating the names of new temporary + * variables. Updated by + * {!Cil.makeLocalVar} and + * {!Cil.makeTempVar}. You can also use + * {!Cil.setMaxId} to set it after you + * have added the formals and locals. *) + mutable sbody: block; (** The function body. *) + mutable smaxstmtid: int option; (** max id of a (reachable) statement + * in this function, if we have + * computed it. range = 0 ... + * (smaxstmtid-1). This is computed by + * {!Cil.computeCFGInfo}. *) + mutable sallstmts: stmt list; (** After you call {!Cil.computeCFGInfo} + * this field is set to contain all + * statements in the function *) + } + + +(** A block is a sequence of statements with the control falling through from + one element to the next *) +and block = + { mutable battrs: attributes; (** Attributes for the block *) + mutable bstmts: stmt list; (** The statements comprising the block*) + } + + +(** {b Statements}. +CIL statements are the structural elements that make the CFG. They are +represented using the type {!Cil.stmt}. Every +statement has a (possibly empty) list of labels. The +{!Cil.stmtkind} field of a statement indicates what kind of statement it +is. + + Use {!Cil.mkStmt} to make a statement and the fill-in the fields. + +CIL also comes with support for control-flow graphs. The [sid] field in +[stmt] can be used to give unique numbers to statements, and the [succs] +and [preds] fields can be used to maintain a list of successors and +predecessors for every statement. The CFG information is not computed by +default. Instead you must explicitly use the functions +{!Cil.prepareCFG} and {!Cil.computeCFGInfo} to do it. + +*) +(** Statements. *) +and stmt = { + mutable labels: label list; + (** Whether the statement starts with some labels, case statements or + * default statements. *) + + mutable skind: stmtkind; + (** The kind of statement *) + + mutable sid: int; + (** A number (>= 0) that is unique in a function. Filled in only after + * the CFG is computed. *) + mutable succs: stmt list; + (** The successor statements. They can always be computed from the skind + * and the context in which this statement appears. Filled in only after + * the CFG is computed. *) + mutable preds: stmt list; + (** The inverse of the succs function. *) + } + +(** Labels *) +and label = + Label of string * location * bool + (** A real label. If the bool is "true", the label is from the + * input source program. If the bool is "false", the label was + * created by CIL or some other transformation *) + | Case of exp * location (** A case statement. This expression + * is lowered into a constant if + * {!Cil.lowerConstants} is set to + * true. *) + | Default of location (** A default statement *) + + + +(** The various kinds of control-flow statements statements *) +and stmtkind = + | Instr of instr list + (** A group of instructions that do not contain control flow. Control + * implicitly falls through. *) + + | Return of exp option * location + (** The return statement. This is a leaf in the CFG. *) + + | Goto of stmt ref * location + (** A goto statement. Appears from actual goto's in the code or from + * goto's that have been inserted during elaboration. The reference + * points to the statement that is the target of the Goto. This means that + * you have to update the reference whenever you replace the target + * statement. The target statement MUST have at least a label. *) + + | Break of location + (** A break to the end of the nearest enclosing loop or Switch *) + + | Continue of location + (** A continue to the start of the nearest enclosing loop *) + | If of exp * block * block * location + (** A conditional. Two successors, the "then" and the "else" branches. + * Both branches fall-through to the successor of the If statement. *) + + | Switch of exp * block * (stmt list) * location + (** A switch statement. The statements that implement the cases can be + * reached through the provided list. For each such target you can find + * among its labels what cases it implements. The statements that + * implement the cases are somewhere within the provided [block]. *) + +(* + | Loop of block * location * (stmt option) * (stmt option) + (** A [while(1)] loop. The termination test is implemented in the body of + * a loop using a [Break] statement. If prepareCFG has been called, + * the first stmt option will point to the stmt containing the continue + * label for this loop and the second will point to the stmt containing + * the break label for this loop. *) +*) + + | While of exp * block * location + (** A [while] loop. *) + + | DoWhile of exp * block * location + (** A [do...while] loop. *) + + | For of block * exp * block * block * location + (** A [for] loop. *) + + | Block of block + (** Just a block of statements. Use it as a way to keep some block + * attributes local *) + + (** On MSVC we support structured exception handling. This is what you + * might expect. Control can get into the finally block either from the + * end of the body block, or if an exception is thrown. *) + | TryFinally of block * block * location + + (** On MSVC we support structured exception handling. The try/except + * statement is a bit tricky: + [__try { blk } + __except (e) { + handler + }] + + The argument to __except must be an expression. However, we keep a + list of instructions AND an expression in case you need to make + function calls. We'll print those as a comma expression. The control + can get to the __except expression only if an exception is thrown. + After that, depending on the value of the expression the control + goes to the handler, propagates the exception, or retries the + exception !!! + *) + | TryExcept of block * (instr list * exp) * block * location + + +(** {b Instructions}. + An instruction {!Cil.instr} is a statement that has no local +(intraprocedural) control flow. It can be either an assignment, +function call, or an inline assembly instruction. *) + +(** Instructions. *) +and instr = + Set of lval * exp * location + (** An assignment. The type of the expression is guaranteed to be the same + * with that of the lvalue *) + | Call of lval option * exp * exp list * location + (** A function call with the (optional) result placed in an lval. It is + * possible that the returned type of the function is not identical to + * that of the lvalue. In that case a cast is printed. The type of the + * actual arguments are identical to those of the declared formals. The + * number of arguments is the same as that of the declared formals, except + * for vararg functions. This construct is also used to encode a call to + * "__builtin_va_arg". In this case the second argument (which should be a + * type T) is encoded SizeOf(T) *) + + | Asm of attributes * (* Really only const and volatile can appear + * here *) + string list * (* templates (CR-separated) *) + (string * lval) list * (* outputs must be lvals with + * constraints. I would like these + * to be actually variables, but I + * run into some trouble with ASMs + * in the Linux sources *) + (string * exp) list * (* inputs with constraints *) + string list * (* register clobbers *) + location + (** There are for storing inline assembly. They follow the GCC + * specification: +{v + asm [volatile] ("...template..." "..template.." + : "c1" (o1), "c2" (o2), ..., "cN" (oN) + : "d1" (i1), "d2" (i2), ..., "dM" (iM) + : "r1", "r2", ..., "nL" ); + v} + +where the parts are + + - [volatile] (optional): when present, the assembler instruction + cannot be removed, moved, or otherwise optimized + - template: a sequence of strings, with %0, %1, %2, etc. in the string to + refer to the input and output expressions. I think they're numbered + consecutively, but the docs don't specify. Each string is printed on + a separate line. This is the only part that is present for MSVC inline + assembly. + - "ci" (oi): pairs of constraint-string and output-lval; the + constraint specifies that the register used must have some + property, like being a floating-point register; the constraint + string for outputs also has "=" to indicate it is written, or + "+" to indicate it is both read and written; 'oi' is the + name of a C lvalue (probably a variable name) to be used as + the output destination + - "dj" (ij): pairs of constraint and input expression; the constraint + is similar to the "ci"s. the 'ij' is an arbitrary C expression + to be loaded into the corresponding register + - "rk": registers to be regarded as "clobbered" by the instruction; + "memory" may be specified for arbitrary memory effects + +an example (from gcc manual): +{v + asm volatile ("movc3 %0,%1,%2" + : /* no outputs */ + : "g" (from), "g" (to), "g" (count) + : "r0", "r1", "r2", "r3", "r4", "r5"); + v} +*) + +(** Describes a location in a source file. *) +and location = { + line: int; (** The line number. -1 means "do not know" *) + file: string; (** The name of the source file*) + byte: int; (** The byte position in the source file *) +} + + +(** Type signatures. Two types are identical iff they have identical + * signatures. These contain the same information as types but canonicalized. + * For example, two function types that are identical except for the name of + * the formal arguments are given the same signature. Also, [TNamed] + * constructors are unrolled. *) +and typsig = + TSArray of typsig * int64 option * attribute list + | TSPtr of typsig * attribute list + | TSComp of bool * string * attribute list + | TSFun of typsig * typsig list * bool * attribute list + | TSEnum of string * attribute list + | TSBase of typ + + + +(** {b Lowering Options} *) + +val lowerConstants: bool ref + (** Do lower constants (default true) *) + +val insertImplicitCasts: bool ref + (** Do insert implicit casts (default true) *) + +(** To be able to add/remove features easily, each feature should be package + * as an interface with the following interface. These features should be *) +type featureDescr = { + fd_enabled: bool ref; + (** The enable flag. Set to default value *) + + fd_name: string; + (** This is used to construct an option "--doxxx" and "--dontxxx" that + * enable and disable the feature *) + + fd_description: string; + (* A longer name that can be used to document the new options *) + + fd_extraopt: (string * Arg.spec * string) list; + (** Additional command line options *) + + fd_doit: (file -> unit); + (** This performs the transformation *) + + fd_post_check: bool; + (* Whether to perform a CIL consistency checking after this stage, if + * checking is enabled (--check is passed to cilly). Set this to true if + * your feature makes any changes for the program. *) +} + +(** Comparison function for locations. + ** Compares first by filename, then line, then byte *) +val compareLoc: location -> location -> int + +(** {b Values for manipulating globals} *) + +(** Make an empty function *) +val emptyFunction: string -> fundec + +(** Update the formals of a [fundec] and make sure that the function type + has the same information. Will copy the name as well into the type. *) +val setFormals: fundec -> varinfo list -> unit + +(** Set the types of arguments and results as given by the function type + * passed as the second argument. Will not copy the names from the function + * type to the formals *) +val setFunctionType: fundec -> typ -> unit + + +(** Set the type of the function and make formal arguments for them *) +val setFunctionTypeMakeFormals: fundec -> typ -> unit + +(** Update the smaxid after you have populated with locals and formals + * (unless you constructed those using {!Cil.makeLocalVar} or + * {!Cil.makeTempVar}. *) +val setMaxId: fundec -> unit + +(** A dummy function declaration handy when you need one as a placeholder. It + * contains inside a dummy varinfo. *) +val dummyFunDec: fundec + +(** A dummy file *) +val dummyFile: file + +(** Write a {!Cil.file} in binary form to the filesystem. The file can be + * read back in later using {!Cil.loadBinaryFile}, possibly saving parsing + * time. The second argument is the name of the file that should be + * created. *) +val saveBinaryFile : file -> string -> unit + +(** Write a {!Cil.file} in binary form to the filesystem. The file can be + * read back in later using {!Cil.loadBinaryFile}, possibly saving parsing + * time. Does not close the channel. *) +val saveBinaryFileChannel : file -> out_channel -> unit + +(** Read a {!Cil.file} in binary form from the filesystem. The first + * argument is the name of a file previously created by + * {!Cil.saveBinaryFile}. *) +val loadBinaryFile : string -> file + +(** Get the global initializer and create one if it does not already exist. + * When it creates a global initializer it attempts to place a call to it in + * the main function named by the optional argument (default "main") *) +val getGlobInit: ?main_name:string -> file -> fundec + +(** Iterate over all globals, including the global initializer *) +val iterGlobals: file -> (global -> unit) -> unit + +(** Fold over all globals, including the global initializer *) +val foldGlobals: file -> ('a -> global -> 'a) -> 'a -> 'a + +(** Map over all globals, including the global initializer and change things + in place *) +val mapGlobals: file -> (global -> global) -> unit + +val new_sid : unit -> int + +(** Prepare a function for CFG information computation by + * {!Cil.computeCFGInfo}. This function converts all [Break], [Switch], + * [Default] and [Continue] {!Cil.stmtkind}s and {!Cil.label}s into [If]s + * and [Goto]s, giving the function body a very CFG-like character. This + * function modifies its argument in place. *) +val prepareCFG: fundec -> unit + +(** Compute the CFG information for all statements in a fundec and return a + * list of the statements. The input fundec cannot have [Break], [Switch], + * [Default], or [Continue] {!Cil.stmtkind}s or {!Cil.label}s. Use + * {!Cil.prepareCFG} to transform them away. The second argument should + * be [true] if you wish a global statement number, [false] if you wish a + * local (per-function) statement numbering. The list of statements is set + * in the sallstmts field of a fundec. + * + * NOTE: unless you want the simpler control-flow graph provided by + * prepareCFG, or you need the function's smaxstmtid and sallstmt fields + * filled in, we recommend you use {!Cfg.computeFileCFG} instead of this + * function to compute control-flow information. + * {!Cfg.computeFileCFG} is newer and will handle switch, break, and + * continue correctly.*) +val computeCFGInfo: fundec -> bool -> unit + + +(** Create a deep copy of a function. There should be no sharing between the + * copy and the original function *) +val copyFunction: fundec -> string -> fundec + + +(** CIL keeps the types at the beginning of the file and the variables at the + * end of the file. This function will take a global and add it to the + * corresponding stack. Its operation is actually more complicated because if + * the global declares a type that contains references to variables (e.g. in + * sizeof in an array length) then it will also add declarations for the + * variables to the types stack *) +val pushGlobal: global -> types: global list ref + -> variables: global list ref -> unit + +(** An empty statement. Used in pretty printing *) +val invalidStmt: stmt + +(** A list of the GCC built-in functions. Maps the name to the result and + * argument types, and whether it is vararg *) +val gccBuiltins: (string, typ * typ list * bool) Hashtbl.t + + +(** A list of the MSVC built-in functions. Maps the name to the result and + * argument types, and whether it is vararg *) +val msvcBuiltins: (string, typ * typ list * bool) Hashtbl.t + +(** {b Values for manipulating initializers} *) + + +(** Make a initializer for zero-ing a data type *) +val makeZeroInit: typ -> init + + +(** Fold over the list of initializers in a Compound. [doinit] is called on + * every present initializer, even if it is of compound type. In the case of + * arrays there might be missing zero-initializers at the end of the list. + * These are not scanned. This is much like [List.fold_left] except we also + * pass the type of the initializer *) +val foldLeftCompound: + doinit: (offset -> init -> typ -> 'a -> 'a) -> + ct: typ -> + initl: (offset * init) list -> + acc: 'a -> 'a + + +(** Fold over the list of initializers in a Compound, like + * {!Cil.foldLeftCompound} but in the case of an array it scans even missing + * zero initializers at the end of the array *) +val foldLeftCompoundAll: + doinit: (offset -> init -> typ -> 'a -> 'a) -> + ct: typ -> + initl: (offset * init) list -> + acc: 'a -> 'a + + + +(** {b Values for manipulating types} *) + +(** void *) +val voidType: typ + +(* is the given type "void"? *) +val isVoidType: typ -> bool + +(* is the given type "void *"? *) +val isVoidPtrType: typ -> bool + +(** int *) +val intType: typ + +(** unsigned int *) +val uintType: typ + +(** long *) +val longType: typ + +(** unsigned long *) +val ulongType: typ + +(** char *) +val charType: typ + +(** char * *) +val charPtrType: typ + +(** wchar_t (depends on architecture) and is set when you call + * {!Cil.initCIL}. *) +val wcharKind: ikind ref +val wcharType: typ ref + +(** char const * *) +val charConstPtrType: typ + +(** void * *) +val voidPtrType: typ + +(** int * *) +val intPtrType: typ + +(** unsigned int * *) +val uintPtrType: typ + +(** double *) +val doubleType: typ + +(* An unsigned integer type that fits pointers. Depends on {!Cil.msvcMode} + * and is set when you call {!Cil.initCIL}. *) +val upointType: typ ref + +(* An unsigned integer type that is the type of sizeof. Depends on + * {!Cil.msvcMode} and is set when you call {!Cil.initCIL}. *) +val typeOfSizeOf: typ ref + +(** Returns true if and only if the given integer type is signed. *) +val isSigned: ikind -> bool + + +(** Creates a a (potentially recursive) composite type. The arguments are: + * (1) a boolean indicating whether it is a struct or a union, (2) the name + * (always non-empty), (3) a function that when given a representation of the + * structure type constructs the type of the fields recursive type (the first + * argument is only useful when some fields need to refer to the type of the + * structure itself), and (4) a list of attributes to be associated with the + * composite type. The resulting compinfo has the field "cdefined" only if + * the list of fields is non-empty. *) +val mkCompInfo: bool -> (* whether it is a struct or a union *) + string -> (* name of the composite type; cannot be empty *) + (compinfo -> + (string * typ * int option * attributes * location) list) -> + (* a function that when given a forward + representation of the structure type constructs the type of + the fields. The function can ignore this argument if not + constructing a recursive type. *) + attributes -> compinfo + +(** Makes a shallow copy of a {!Cil.compinfo} changing the name and the key.*) +val copyCompInfo: compinfo -> string -> compinfo + +(** This is a constant used as the name of an unnamed bitfield. These fields + do not participate in initialization and their name is not printed. *) +val missingFieldName: string + +(** Get the full name of a comp *) +val compFullName: compinfo -> string + +(** Returns true if this is a complete type. + This means that sizeof(t) makes sense. + Incomplete types are not yet defined + structures and empty arrays. *) +val isCompleteType: typ -> bool + +(** Unroll a type until it exposes a non + * [TNamed]. Will collect all attributes appearing in [TNamed]!!! *) +val unrollType: typ -> typ + +(** Unroll all the TNamed in a type (even under type constructors such as + * [TPtr], [TFun] or [TArray]. Does not unroll the types of fields in [TComp] + * types. Will collect all attributes *) +val unrollTypeDeep: typ -> typ + +(** Separate out the storage-modifier name attributes *) +val separateStorageModifiers: attribute list -> attribute list * attribute list + +(** True if the argument is an integral type (i.e. integer or enum) *) +val isIntegralType: typ -> bool + +(** True if the argument is an arithmetic type (i.e. integer, enum or + floating point *) +val isArithmeticType: typ -> bool + +(**True if the argument is a pointer type *) +val isPointerType: typ -> bool + +(** True if the argument is a function type *) +val isFunctionType: typ -> bool + +(** Obtain the argument list ([] if None) *) +val argsToList: (string * typ * attributes) list option + -> (string * typ * attributes) list + +(** True if the argument is an array type *) +val isArrayType: typ -> bool + +(** Raised when {!Cil.lenOfArray} fails either because the length is [None] + * or because it is a non-constant expression *) +exception LenOfArray + +(** Call to compute the array length as present in the array type, to an + * integer. Raises {!Cil.LenOfArray} if not able to compute the length, such + * as when there is no length or the length is not a constant. *) +val lenOfArray: exp option -> int + +(** Return a named fieldinfo in compinfo, or raise Not_found *) +val getCompField: compinfo -> string -> fieldinfo + + +(** A datatype to be used in conjunction with [existsType] *) +type existsAction = + ExistsTrue (* We have found it *) + | ExistsFalse (* Stop processing this branch *) + | ExistsMaybe (* This node is not what we are + * looking for but maybe its + * successors are *) + +(** Scans a type by applying the function on all elements. + When the function returns ExistsTrue, the scan stops with + true. When the function returns ExistsFalse then the current branch is not + scanned anymore. Care is taken to + apply the function only once on each composite type, thus avoiding + circularity. When the function returns ExistsMaybe then the types that + construct the current type are scanned (e.g. the base type for TPtr and + TArray, the type of fields for a TComp, etc). *) +val existsType: (typ -> existsAction) -> typ -> bool + + +(** Given a function type split it into return type, + * arguments, is_vararg and attributes. An error is raised if the type is not + * a function type *) +val splitFunctionType: + typ -> typ * (string * typ * attributes) list option * bool * attributes +(** Same as {!Cil.splitFunctionType} but takes a varinfo. Prints a nicer + * error message if the varinfo is not for a function *) +val splitFunctionTypeVI: + varinfo -> typ * (string * typ * attributes) list option * bool * attributes + + +(** {b Type signatures} *) + +(** Type signatures. Two types are identical iff they have identical + * signatures. These contain the same information as types but canonicalized. + * For example, two function types that are identical except for the name of + * the formal arguments are given the same signature. Also, [TNamed] + * constructors are unrolled. You shoud use [Util.equals] to compare type + * signatures because they might still contain circular structures (through + * attributes, and sizeof) *) + +(** Print a type signature *) +val d_typsig: unit -> typsig -> Pretty.doc + +(** Compute a type signature *) +val typeSig: typ -> typsig + +(** Like {!Cil.typeSig} but customize the incorporation of attributes. + Use ~ignoreSign:true to convert all signed integer types to unsigned, + so that signed and unsigned will compare the same. *) +val typeSigWithAttrs: ?ignoreSign:bool -> (attributes -> attributes) -> typ -> typsig + +(** Replace the attributes of a signature (only at top level) *) +val setTypeSigAttrs: attributes -> typsig -> typsig + +(** Get the top-level attributes of a signature *) +val typeSigAttrs: typsig -> attributes + +(*********************************************************) +(** LVALUES *) + +(** Make a varinfo. Use this (rarely) to make a raw varinfo. Use other + * functions to make locals ({!Cil.makeLocalVar} or {!Cil.makeFormalVar} or + * {!Cil.makeTempVar}) and globals ({!Cil.makeGlobalVar}). Note that this + * function will assign a new identifier. The first argument specifies + * whether the varinfo is for a global. *) +val makeVarinfo: bool -> string -> typ -> varinfo + +(** Make a formal variable for a function. Insert it in both the sformals + and the type of the function. You can optionally specify where to insert + this one. If where = "^" then it is inserted first. If where = "$" then + it is inserted last. Otherwise where must be the name of a formal after + which to insert this. By default it is inserted at the end. *) +val makeFormalVar: fundec -> ?where:string -> string -> typ -> varinfo + +(** Make a local variable and add it to a function's slocals (only if insert = + true, which is the default). Make sure you know what you are doing if you + set insert=false. *) +val makeLocalVar: fundec -> ?insert:bool -> string -> typ -> varinfo + +(** Make a temporary variable and add it to a function's slocals. The name of + the temporary variable will be generated based on the given name hint so + that to avoid conflicts with other locals. *) +val makeTempVar: fundec -> ?name: string -> typ -> varinfo + + +(** Make a global variable. Your responsibility to make sure that the name + is unique *) +val makeGlobalVar: string -> typ -> varinfo + +(** Make a shallow copy of a [varinfo] and assign a new identifier *) +val copyVarinfo: varinfo -> string -> varinfo + + +(** Generate a new variable ID. This will be different than any variable ID + * that is generated by {!Cil.makeLocalVar} and friends *) +val newVID: unit -> int + +(** Add an offset at the end of an lvalue. Make sure the type of the lvalue + * and the offset are compatible. *) +val addOffsetLval: offset -> lval -> lval + +(** [addOffset o1 o2] adds [o1] to the end of [o2]. *) +val addOffset: offset -> offset -> offset + +(** Remove ONE offset from the end of an lvalue. Returns the lvalue with the + * trimmed offset and the final offset. If the final offset is [NoOffset] + * then the original [lval] did not have an offset. *) +val removeOffsetLval: lval -> lval * offset + +(** Remove ONE offset from the end of an offset sequence. Returns the + * trimmed offset and the final offset. If the final offset is [NoOffset] + * then the original [lval] did not have an offset. *) +val removeOffset: offset -> offset * offset + +(** Compute the type of an lvalue *) +val typeOfLval: lval -> typ + +(** Compute the type of an offset from a base type *) +val typeOffset: typ -> offset -> typ + + +(*******************************************************) +(** {b Values for manipulating expressions} *) + + +(* Construct integer constants *) + +(** 0 *) +val zero: exp + +(** 1 *) +val one: exp + +(** -1 *) +val mone: exp + + +(** Construct an integer of a given kind, using OCaml's int64 type. If needed + * it will truncate the integer to be within the representable range for the + * given kind. *) +val kinteger64: ikind -> int64 -> exp + +(** Construct an integer of a given kind. Converts the integer to int64 and + * then uses kinteger64. This might truncate the value if you use a kind + * that cannot represent the given integer. This can only happen for one of + * the Char or Short kinds *) +val kinteger: ikind -> int -> exp + +(** Construct an integer of kind IInt. You can use this always since the + OCaml integers are 31 bits and are guaranteed to fit in an IInt *) +val integer: int -> exp + + +(** True if the given expression is a (possibly cast'ed) + character or an integer constant *) +val isInteger: exp -> int64 option + +(** True if the expression is a compile-time constant *) +val isConstant: exp -> bool + +(** True if the given expression is a (possibly cast'ed) integer or character + constant with value zero *) +val isZero: exp -> bool + +(** Given the character c in a (CChr c), sign-extend it to 32 bits. + (This is the official way of interpreting character constants, according to + ISO C 6.4.4.4.10, which says that character constants are chars cast to ints) + Returns CInt64(sign-extened c, IInt, None) *) +val charConstToInt: char -> constant + +(** Do constant folding on an expression. If the first argument is true then + will also compute compiler-dependent expressions such as sizeof *) +val constFold: bool -> exp -> exp + +(** Do constant folding on a binary operation. The bulk of the work done by + [constFold] is done here. If the first argument is true then + will also compute compiler-dependent expressions such as sizeof *) +val constFoldBinOp: bool -> binop -> exp -> exp -> typ -> exp + +(** Increment an expression. Can be arithmetic or pointer type *) +val increm: exp -> int -> exp + + +(** Makes an lvalue out of a given variable *) +val var: varinfo -> lval + +(** Make an AddrOf. Given an lvalue of type T will give back an expression of + type ptr(T). It optimizes somewhat expressions like "& v" and "& v[0]" *) +val mkAddrOf: lval -> exp + + +(** Like mkAddrOf except if the type of lval is an array then it uses + StartOf. This is the right operation for getting a pointer to the start + of the storage denoted by lval. *) +val mkAddrOrStartOf: lval -> exp + +(** Make a Mem, while optimizing AddrOf. The type of the addr must be + TPtr(t) and the type of the resulting lval is t. Note that in CIL the + implicit conversion between an array and the pointer to the first + element does not apply. You must do the conversion yourself using + StartOf *) +val mkMem: addr:exp -> off:offset -> lval + +(** Make an expression that is a string constant (of pointer type) *) +val mkString: string -> exp + +(** Construct a cast when having the old type of the expression. If the new + * type is the same as the old type, then no cast is added. *) +val mkCastT: e:exp -> oldt:typ -> newt:typ -> exp + +(** Like {!Cil.mkCastT} but uses typeOf to get [oldt] *) +val mkCast: e:exp -> newt:typ -> exp + +(** Removes casts from this expression, but ignores casts within + other expression constructs. So we delete the (A) and (B) casts from + "(A)(B)(x + (C)y)", but leave the (C) cast. *) +val stripCasts: exp -> exp + +(** Compute the type of an expression *) +val typeOf: exp -> typ + +(** Convert a string representing a C integer literal to an expression. + * Handles the prefixes 0x and 0 and the suffixes L, U, UL, LL, ULL *) +val parseInt: string -> exp + + +(**********************************************) +(** {b Values for manipulating statements} *) + +(** Construct a statement, given its kind. Initialize the [sid] field to -1, + and [labels], [succs] and [preds] to the empty list *) +val mkStmt: stmtkind -> stmt + +(** Construct a block with no attributes, given a list of statements *) +val mkBlock: stmt list -> block + +(** Construct a statement consisting of just one instruction *) +val mkStmtOneInstr: instr -> stmt + +(** Try to compress statements so as to get maximal basic blocks *) +(* use this instead of List.@ because you get fewer basic blocks *) +val compactStmts: stmt list -> stmt list + +(** Returns an empty statement (of kind [Instr]) *) +val mkEmptyStmt: unit -> stmt + +(** A instr to serve as a placeholder *) +val dummyInstr: instr + +(** A statement consisting of just [dummyInstr] *) +val dummyStmt: stmt + +(** Make a while loop. Can contain Break or Continue *) +val mkWhile: guard:exp -> body:stmt list -> stmt list + +(** Make a for loop for(i=start; i first:exp -> stopat:exp -> incr:exp + -> body:stmt list -> stmt list + +(** Make a for loop for(start; guard; next) \{ ... \}. The body can + contain Break but not Continue !!! *) +val mkFor: start:stmt list -> guard:exp -> next: stmt list -> + body: stmt list -> stmt list + + + +(**************************************************) +(** {b Values for manipulating attributes} *) + +(** Various classes of attributes *) +type attributeClass = + AttrName of bool + (** Attribute of a name. If argument is true and we are on MSVC then + the attribute is printed using __declspec as part of the storage + specifier *) + | AttrFunType of bool + (** Attribute of a function type. If argument is true and we are on + MSVC then the attribute is printed just before the function name *) + | AttrType (** Attribute of a type *) + +(** This table contains the mapping of predefined attributes to classes. + Extend this table with more attributes as you need. This table is used to + determine how to associate attributes with names or types *) +val attributeHash: (string, attributeClass) Hashtbl.t + +(** Partition the attributes into classes:name attributes, function type, + and type attributes *) +val partitionAttributes: default:attributeClass -> + attributes -> attribute list * (* AttrName *) + attribute list * (* AttrFunType *) + attribute list (* AttrType *) + +(** Add an attribute. Maintains the attributes in sorted order of the second + argument *) +val addAttribute: attribute -> attributes -> attributes + +(** Add a list of attributes. Maintains the attributes in sorted order. The + second argument must be sorted, but not necessarily the first *) +val addAttributes: attribute list -> attributes -> attributes + +(** Remove all attributes with the given name. Maintains the attributes in + sorted order. *) +val dropAttribute: string -> attributes -> attributes + +(** Remove all attributes with names appearing in the string list. + * Maintains the attributes in sorted order *) +val dropAttributes: string list -> attributes -> attributes + +(** Retains attributes with the given name *) +val filterAttributes: string -> attributes -> attributes + +(** True if the named attribute appears in the attribute list. The list of + attributes must be sorted. *) +val hasAttribute: string -> attributes -> bool + +(** Returns all the attributes contained in a type. This requires a traversal + of the type structure, in case of composite, enumeration and named types *) +val typeAttrs: typ -> attribute list + +val setTypeAttrs: typ -> attributes -> typ (* Resets the attributes *) + + +(** Add some attributes to a type *) +val typeAddAttributes: attribute list -> typ -> typ + +(** Remove all attributes with the given names from a type. Note that this + does not remove attributes from typedef and tag definitions, just from + their uses *) +val typeRemoveAttributes: string list -> typ -> typ + + +(****************** + ****************** VISITOR + ******************) +(** {b The visitor} *) + +(** Different visiting actions. 'a will be instantiated with [exp], [instr], + etc. *) +type 'a visitAction = + SkipChildren (** Do not visit the children. Return + the node as it is. *) + | DoChildren (** Continue with the children of this + node. Rebuild the node on return + if any of the children changes + (use == test) *) + | ChangeTo of 'a (** Replace the expression with the + given one *) + | ChangeDoChildrenPost of 'a * ('a -> 'a) (** First consider that the entire + exp is replaced by the first + parameter. Then continue with + the children. On return rebuild + the node if any of the children + has changed and then apply the + function on the node *) + + + +(** A visitor interface for traversing CIL trees. Create instantiations of + * this type by specializing the class {!Cil.nopCilVisitor}. Each of the + * specialized visiting functions can also call the [queueInstr] to specify + * that some instructions should be inserted before the current instruction + * or statement. Use syntax like [self#queueInstr] to call a method + * associated with the current object. *) +class type cilVisitor = object + method vvdec: varinfo -> varinfo visitAction + (** Invoked for each variable declaration. The subtrees to be traversed + * are those corresponding to the type and attributes of the variable. + * Note that variable declarations are all the [GVar], [GVarDecl], [GFun], + * all the [varinfo] in formals of function types, and the formals and + * locals for function definitions. This means that the list of formals + * in a function definition will be traversed twice, once as part of the + * function type and second as part of the formals in a function + * definition. *) + + method vvrbl: varinfo -> varinfo visitAction + (** Invoked on each variable use. Here only the [SkipChildren] and + * [ChangeTo] actions make sense since there are no subtrees. Note that + * the type and attributes of the variable are not traversed for a + * variable use *) + + method vexpr: exp -> exp visitAction + (** Invoked on each expression occurrence. The subtrees are the + * subexpressions, the types (for a [Cast] or [SizeOf] expression) or the + * variable use. *) + + method vlval: lval -> lval visitAction + (** Invoked on each lvalue occurrence *) + + method voffs: offset -> offset visitAction + (** Invoked on each offset occurrence that is *not* as part + * of an initializer list specification, i.e. in an lval or + * recursively inside an offset. *) + + method vinitoffs: offset -> offset visitAction + (** Invoked on each offset appearing in the list of a + * CompoundInit initializer. *) + + method vinst: instr -> instr list visitAction + (** Invoked on each instruction occurrence. The [ChangeTo] action can + * replace this instruction with a list of instructions *) + + method vstmt: stmt -> stmt visitAction + (** Control-flow statement. The default [DoChildren] action does not + * create a new statement when the components change. Instead it updates + * the contents of the original statement. This is done to preserve the + * sharing with [Goto] and [Case] statements that point to the original + * statement. If you use the [ChangeTo] action then you should take care + * of preserving that sharing yourself. *) + + method vblock: block -> block visitAction (** Block. *) + method vfunc: fundec -> fundec visitAction (** Function definition. + Replaced in place. *) + method vglob: global -> global list visitAction (** Global (vars, types, + etc.) *) + method vinit: init -> init visitAction (** Initializers for globals *) + method vtype: typ -> typ visitAction (** Use of some type. Note + * that for structure/union + * and enumeration types the + * definition of the + * composite type is not + * visited. Use [vglob] to + * visit it. *) + method vattr: attribute -> attribute list visitAction + (** Attribute. Each attribute can be replaced by a list *) + method vattrparam: attrparam -> attrparam visitAction + (** Attribute parameters. *) + + (** Add here instructions while visiting to queue them to preceede the + * current statement or instruction being processed. Use this method only + * when you are visiting an expression that is inside a function body, or + * a statement, because otherwise there will no place for the visitor to + * place your instructions. *) + method queueInstr: instr list -> unit + + (** Gets the queue of instructions and resets the queue. This is done + * automatically for you when you visit statments. *) + method unqueueInstr: unit -> instr list + +end + +(** Default Visitor. Traverses the CIL tree without modifying anything *) +class nopCilVisitor: cilVisitor + +(* other cil constructs *) + +(** Visit a file. This will will re-cons all globals TWICE (so that it is + * tail-recursive). Use {!Cil.visitCilFileSameGlobals} if your visitor will + * not change the list of globals. *) +val visitCilFile: cilVisitor -> file -> unit + +(** A visitor for the whole file that does not change the globals (but maybe + * changes things inside the globals). Use this function instead of + * {!Cil.visitCilFile} whenever appropriate because it is more efficient for + * long files. *) +val visitCilFileSameGlobals: cilVisitor -> file -> unit + +(** Visit a global *) +val visitCilGlobal: cilVisitor -> global -> global list + +(** Visit a function definition *) +val visitCilFunction: cilVisitor -> fundec -> fundec + +(* Visit an expression *) +val visitCilExpr: cilVisitor -> exp -> exp + +(** Visit an lvalue *) +val visitCilLval: cilVisitor -> lval -> lval + +(** Visit an lvalue or recursive offset *) +val visitCilOffset: cilVisitor -> offset -> offset + +(** Visit an initializer offset *) +val visitCilInitOffset: cilVisitor -> offset -> offset + +(** Visit an instruction *) +val visitCilInstr: cilVisitor -> instr -> instr list + +(** Visit a statement *) +val visitCilStmt: cilVisitor -> stmt -> stmt + +(** Visit a block *) +val visitCilBlock: cilVisitor -> block -> block + +(** Visit a type *) +val visitCilType: cilVisitor -> typ -> typ + +(** Visit a variable declaration *) +val visitCilVarDecl: cilVisitor -> varinfo -> varinfo + +(** Visit an initializer *) +val visitCilInit: cilVisitor -> init -> init + + +(** Visit a list of attributes *) +val visitCilAttributes: cilVisitor -> attribute list -> attribute list + +(* And some generic visitors. The above are built with these *) + + +(** {b Utility functions} *) + +(** Whether the pretty printer should print output for the MS VC compiler. + Default is GCC. After you set this function you should call {!Cil.initCIL}. *) +val msvcMode: bool ref + + +(** Whether to use the logical operands LAnd and LOr. By default, do not use + * them because they are unlike other expressions and do not evaluate both of + * their operands *) +val useLogicalOperators: bool ref + + +(** A visitor that does constant folding. Pass as argument whether you want + * machine specific simplifications to be done, or not. *) +val constFoldVisitor: bool -> cilVisitor + +(** Styles of printing line directives *) +type lineDirectiveStyle = + | LineComment + | LinePreprocessorInput + | LinePreprocessorOutput + +(** How to print line directives *) +val lineDirectiveStyle: lineDirectiveStyle option ref + +(** Whether we print something that will only be used as input to our own + * parser. In that case we are a bit more liberal in what we print *) +val print_CIL_Input: bool ref + +(** Whether to print the CIL as they are, without trying to be smart and + * print nicer code. Normally this is false, in which case the pretty + * printer will turn the while(1) loops of CIL into nicer loops, will not + * print empty "else" blocks, etc. These is one case howewer in which if you + * turn this on you will get code that does not compile: if you use varargs + * the __builtin_va_arg function will be printed in its internal form. *) +val printCilAsIs: bool ref + +(** The length used when wrapping output lines. Setting this variable to + * a large integer will prevent wrapping and make #line directives more + * accurate. + *) +val lineLength: int ref + +(** Return the string 's' if we're printing output for gcc, suppres + * it if we're printing for CIL to parse back in. the purpose is to + * hide things from gcc that it complains about, but still be able + * to do lossless transformations when CIL is the consumer *) +val forgcc: string -> string + +(** {b Debugging support} *) + +(** A reference to the current location. If you are careful to set this to + * the current location then you can use some built-in logging functions that + * will print the location. *) +val currentLoc: location ref + +(** A reference to the current global being visited *) +val currentGlobal: global ref + + +(** CIL has a fairly easy to use mechanism for printing error messages. This + * mechanism is built on top of the pretty-printer mechanism (see + * {!Pretty.doc}) and the error-message modules (see {!Errormsg.error}). + + Here is a typical example for printing a log message: {v +ignore (Errormsg.log "Expression %a is not positive (at %s:%i)\n" + d_exp e loc.file loc.line) + v} + + and here is an example of how you print a fatal error message that stop the +* execution: {v +Errormsg.s (Errormsg.bug "Why am I here?") + v} + + Notice that you can use C format strings with some extension. The most +useful extension is "%a" that means to consumer the next two argument from +the argument list and to apply the first to [unit] and then to the second +and to print the resulting {!Pretty.doc}. For each major type in CIL there is +a corresponding function that pretty-prints an element of that type: +*) + + +(** Pretty-print a location *) +val d_loc: unit -> location -> Pretty.doc + +(** Pretty-print the {!Cil.currentLoc} *) +val d_thisloc: unit -> Pretty.doc + +(** Pretty-print an integer of a given kind *) +val d_ikind: unit -> ikind -> Pretty.doc + +(** Pretty-print a floating-point kind *) +val d_fkind: unit -> fkind -> Pretty.doc + +(** Pretty-print storage-class information *) +val d_storage: unit -> storage -> Pretty.doc + +(** Pretty-print a constant *) +val d_const: unit -> constant -> Pretty.doc + + +val derefStarLevel: int +val indexLevel: int +val arrowLevel: int +val addrOfLevel: int +val additiveLevel: int +val comparativeLevel: int +val bitwiseLevel: int + +(** Parentheses level. An expression "a op b" is printed parenthesized if its + * parentheses level is >= that that of its context. Identifiers have the + * lowest level and weakly binding operators (e.g. |) have the largest level. + * The correctness criterion is that a smaller level MUST correspond to a + * stronger precedence! + *) +val getParenthLevel: exp -> int + +(** A printer interface for CIL trees. Create instantiations of + * this type by specializing the class {!Cil.defaultCilPrinterClass}. *) +class type cilPrinter = object + method pVDecl: unit -> varinfo -> Pretty.doc + (** Invoked for each variable declaration. Note that variable + * declarations are all the [GVar], [GVarDecl], [GFun], all the [varinfo] + * in formals of function types, and the formals and locals for function + * definitions. *) + + method pVar: varinfo -> Pretty.doc + (** Invoked on each variable use. *) + + method pLval: unit -> lval -> Pretty.doc + (** Invoked on each lvalue occurrence *) + + method pOffset: Pretty.doc -> offset -> Pretty.doc + (** Invoked on each offset occurrence. The second argument is the base. *) + + method pInstr: unit -> instr -> Pretty.doc + (** Invoked on each instruction occurrence. *) + + method pLabel: unit -> label -> Pretty.doc + (** Print a label. *) + + method pStmt: unit -> stmt -> Pretty.doc + (** Control-flow statement. This is used by + * {!Cil.printGlobal} and by {!Cil.dumpGlobal}. *) + + method dStmt: out_channel -> int -> stmt -> unit + (** Dump a control-flow statement to a file with a given indentation. + * This is used by {!Cil.dumpGlobal}. *) + + method dBlock: out_channel -> int -> block -> unit + (** Dump a control-flow block to a file with a given indentation. + * This is used by {!Cil.dumpGlobal}. *) + + method pBlock: unit -> block -> Pretty.doc + + method pBlock: unit -> block -> Pretty.doc + (** Print a block. *) + + method pGlobal: unit -> global -> Pretty.doc + (** Global (vars, types, etc.). This can be slow and is used only by + * {!Cil.printGlobal} but not by {!Cil.dumpGlobal}. *) + + method dGlobal: out_channel -> global -> unit + (** Dump a global to a file with a given indentation. This is used by + * {!Cil.dumpGlobal} *) + + method pFieldDecl: unit -> fieldinfo -> Pretty.doc + (** A field declaration *) + + method pType: Pretty.doc option -> unit -> typ -> Pretty.doc + (* Use of some type in some declaration. The first argument is used to print + * the declared element, or is None if we are just printing a type with no + * name being declared. Note that for structure/union and enumeration types + * the definition of the composite type is not visited. Use [vglob] to + * visit it. *) + + method pAttr: attribute -> Pretty.doc * bool + (** Attribute. Also return an indication whether this attribute must be + * printed inside the __attribute__ list or not. *) + + method pAttrParam: unit -> attrparam -> Pretty.doc + (** Attribute parameter *) + + method pAttrs: unit -> attributes -> Pretty.doc + (** Attribute lists *) + + method pLineDirective: ?forcefile:bool -> location -> Pretty.doc + (** Print a line-number. This is assumed to come always on an empty line. + * If the forcefile argument is present and is true then the file name + * will be printed always. Otherwise the file name is printed only if it + * is different from the last time time this function is called. The last + * file name is stored in a private field inside the cilPrinter object. *) + + method pStmtKind: stmt -> unit -> stmtkind -> Pretty.doc + (** Print a statement kind. The code to be printed is given in the + * {!Cil.stmtkind} argument. The initial {!Cil.stmt} argument + * records the statement which follows the one being printed; + * {!Cil.defaultCilPrinterClass} uses this information to prettify + * statement printing in certain special cases. *) + + method pExp: unit -> exp -> Pretty.doc + (** Print expressions *) + + method pInit: unit -> init -> Pretty.doc + (** Print initializers. This can be slow and is used by + * {!Cil.printGlobal} but not by {!Cil.dumpGlobal}. *) + + method dInit: out_channel -> int -> init -> unit + (** Dump a global to a file with a given indentation. This is used by + * {!Cil.dumpGlobal} *) +end + +class defaultCilPrinterClass: cilPrinter +val defaultCilPrinter: cilPrinter + +(** These are pretty-printers that will show you more details on the internal + * CIL representation, without trying hard to make it look like C *) +class plainCilPrinterClass: cilPrinter +val plainCilPrinter: cilPrinter + +(* zra: This is the pretty printer that Maincil will use. + by default it is set to defaultCilPrinter *) +val printerForMaincil: cilPrinter ref + +(* Top-level printing functions *) +(** Print a type given a pretty printer *) +val printType: cilPrinter -> unit -> typ -> Pretty.doc + +(** Print an expression given a pretty printer *) +val printExp: cilPrinter -> unit -> exp -> Pretty.doc + +(** Print an lvalue given a pretty printer *) +val printLval: cilPrinter -> unit -> lval -> Pretty.doc + +(** Print a global given a pretty printer *) +val printGlobal: cilPrinter -> unit -> global -> Pretty.doc + +(** Print an attribute given a pretty printer *) +val printAttr: cilPrinter -> unit -> attribute -> Pretty.doc + +(** Print a set of attributes given a pretty printer *) +val printAttrs: cilPrinter -> unit -> attributes -> Pretty.doc + +(** Print an instruction given a pretty printer *) +val printInstr: cilPrinter -> unit -> instr -> Pretty.doc + +(** Print a statement given a pretty printer. This can take very long + * (or even overflow the stack) for huge statements. Use {!Cil.dumpStmt} + * instead. *) +val printStmt: cilPrinter -> unit -> stmt -> Pretty.doc + +(** Print a block given a pretty printer. This can take very long + * (or even overflow the stack) for huge block. Use {!Cil.dumpBlock} + * instead. *) +val printBlock: cilPrinter -> unit -> block -> Pretty.doc + +(** Dump a statement to a file using a given indentation. Use this instead of + * {!Cil.printStmt} whenever possible. *) +val dumpStmt: cilPrinter -> out_channel -> int -> stmt -> unit + +(** Dump a block to a file using a given indentation. Use this instead of + * {!Cil.printBlock} whenever possible. *) +val dumpBlock: cilPrinter -> out_channel -> int -> block -> unit + +(** Print an initializer given a pretty printer. This can take very long + * (or even overflow the stack) for huge initializers. Use {!Cil.dumpInit} + * instead. *) +val printInit: cilPrinter -> unit -> init -> Pretty.doc + +(** Dump an initializer to a file using a given indentation. Use this instead of + * {!Cil.printInit} whenever possible. *) +val dumpInit: cilPrinter -> out_channel -> int -> init -> unit + +(** Pretty-print a type using {!Cil.defaultCilPrinter} *) +val d_type: unit -> typ -> Pretty.doc + +(** Pretty-print an expression using {!Cil.defaultCilPrinter} *) +val d_exp: unit -> exp -> Pretty.doc + +(** Pretty-print an lvalue using {!Cil.defaultCilPrinter} *) +val d_lval: unit -> lval -> Pretty.doc + +(** Pretty-print an offset using {!Cil.defaultCilPrinter}, given the pretty + * printing for the base. *) +val d_offset: Pretty.doc -> unit -> offset -> Pretty.doc + +(** Pretty-print an initializer using {!Cil.defaultCilPrinter}. This can be + * extremely slow (or even overflow the stack) for huge initializers. Use + * {!Cil.dumpInit} instead. *) +val d_init: unit -> init -> Pretty.doc + +(** Pretty-print a binary operator *) +val d_binop: unit -> binop -> Pretty.doc + +(** Pretty-print a unary operator *) +val d_unop: unit -> unop -> Pretty.doc + +(** Pretty-print an attribute using {!Cil.defaultCilPrinter} *) +val d_attr: unit -> attribute -> Pretty.doc + +(** Pretty-print an argument of an attribute using {!Cil.defaultCilPrinter} *) +val d_attrparam: unit -> attrparam -> Pretty.doc + +(** Pretty-print a list of attributes using {!Cil.defaultCilPrinter} *) +val d_attrlist: unit -> attributes -> Pretty.doc + +(** Pretty-print an instruction using {!Cil.defaultCilPrinter} *) +val d_instr: unit -> instr -> Pretty.doc + +(** Pretty-print a label using {!Cil.defaultCilPrinter} *) +val d_label: unit -> label -> Pretty.doc + +(** Pretty-print a statement using {!Cil.defaultCilPrinter}. This can be + * extremely slow (or even overflow the stack) for huge statements. Use + * {!Cil.dumpStmt} instead. *) +val d_stmt: unit -> stmt -> Pretty.doc + +(** Pretty-print a block using {!Cil.defaultCilPrinter}. This can be + * extremely slow (or even overflow the stack) for huge blocks. Use + * {!Cil.dumpBlock} instead. *) +val d_block: unit -> block -> Pretty.doc + +(** Pretty-print the internal representation of a global using + * {!Cil.defaultCilPrinter}. This can be extremely slow (or even overflow the + * stack) for huge globals (such as arrays with lots of initializers). Use + * {!Cil.dumpGlobal} instead. *) +val d_global: unit -> global -> Pretty.doc + + +(** Versions of the above pretty printers, that don't print #line directives *) +val dn_exp : unit -> exp -> Pretty.doc +val dn_lval : unit -> lval -> Pretty.doc +(* dn_offset is missing because it has a different interface *) +val dn_init : unit -> init -> Pretty.doc +val dn_type : unit -> typ -> Pretty.doc +val dn_global : unit -> global -> Pretty.doc +val dn_attrlist : unit -> attributes -> Pretty.doc +val dn_attr : unit -> attribute -> Pretty.doc +val dn_attrparam : unit -> attrparam -> Pretty.doc +val dn_stmt : unit -> stmt -> Pretty.doc +val dn_instr : unit -> instr -> Pretty.doc + + +(** Pretty-print a short description of the global. This is useful for error + * messages *) +val d_shortglobal: unit -> global -> Pretty.doc + +(** Pretty-print a global. Here you give the channel where the printout + * should be sent. *) +val dumpGlobal: cilPrinter -> out_channel -> global -> unit + +(** Pretty-print an entire file. Here you give the channel where the printout + * should be sent. *) +val dumpFile: cilPrinter -> out_channel -> string -> file -> unit + + +(* the following error message producing functions also print a location in + * the code. use {!Errormsg.bug} and {!Errormsg.unimp} if you do not want + * that *) + +(** Like {!Errormsg.bug} except that {!Cil.currentLoc} is also printed *) +val bug: ('a,unit,Pretty.doc) format -> 'a + +(** Like {!Errormsg.unimp} except that {!Cil.currentLoc}is also printed *) +val unimp: ('a,unit,Pretty.doc) format -> 'a + +(** Like {!Errormsg.error} except that {!Cil.currentLoc} is also printed *) +val error: ('a,unit,Pretty.doc) format -> 'a + +(** Like {!Cil.error} except that it explicitly takes a location argument, + * instead of using the {!Cil.currentLoc} *) +val errorLoc: location -> ('a,unit,Pretty.doc) format -> 'a + +(** Like {!Errormsg.warn} except that {!Cil.currentLoc} is also printed *) +val warn: ('a,unit,Pretty.doc) format -> 'a + + +(** Like {!Errormsg.warnOpt} except that {!Cil.currentLoc} is also printed. + * This warning is printed only of {!Errormsg.warnFlag} is set. *) +val warnOpt: ('a,unit,Pretty.doc) format -> 'a + +(** Like {!Errormsg.warn} except that {!Cil.currentLoc} and context + is also printed *) +val warnContext: ('a,unit,Pretty.doc) format -> 'a + +(** Like {!Errormsg.warn} except that {!Cil.currentLoc} and context is also + * printed. This warning is printed only of {!Errormsg.warnFlag} is set. *) +val warnContextOpt: ('a,unit,Pretty.doc) format -> 'a + +(** Like {!Cil.warn} except that it explicitly takes a location argument, + * instead of using the {!Cil.currentLoc} *) +val warnLoc: location -> ('a,unit,Pretty.doc) format -> 'a + +(** Sometimes you do not want to see the syntactic sugar that the above + * pretty-printing functions add. In that case you can use the following + * pretty-printing functions. But note that the output of these functions is + * not valid C *) + +(** Pretty-print the internal representation of an expression *) +val d_plainexp: unit -> exp -> Pretty.doc + +(** Pretty-print the internal representation of an integer *) +val d_plaininit: unit -> init -> Pretty.doc + +(** Pretty-print the internal representation of an lvalue *) +val d_plainlval: unit -> lval -> Pretty.doc + +(** Pretty-print the internal representation of an lvalue offset +val d_plainoffset: unit -> offset -> Pretty.doc *) + +(** Pretty-print the internal representation of a type *) +val d_plaintype: unit -> typ -> Pretty.doc + + + +(** {b ALPHA conversion} has been moved to the Alpha module. *) + + +(** Assign unique names to local variables. This might be necessary after you + * transformed the code and added or renamed some new variables. Names are + * not used by CIL internally, but once you print the file out the compiler + * downstream might be confused. You might + * have added a new global that happens to have the same name as a local in + * some function. Rename the local to ensure that there would never be + * confusioin. Or, viceversa, you might have added a local with a name that + * conflicts with a global *) +val uniqueVarNames: file -> unit + +(** {b Optimization Passes} *) + +(** A peephole optimizer that processes two adjacent statements and possibly + replaces them both. If some replacement happens, then the new statements + are themselves subject to optimization *) +val peepHole2: (instr * instr -> instr list option) -> stmt list -> unit + +(** Similar to [peepHole2] except that the optimization window consists of + one statement, not two *) +val peepHole1: (instr -> instr list option) -> stmt list -> unit + +(** {b Machine dependency} *) + + +(** Raised when one of the bitsSizeOf functions cannot compute the size of a + * type. This can happen because the type contains array-length expressions + * that we don't know how to compute or because it is a type whose size is + * not defined (e.g. TFun or an undefined compinfo). The string is an + * explanation of the error *) +exception SizeOfError of string * typ + +(** The size of a type, in bits. Trailing padding is added for structs and + * arrays. Raises {!Cil.SizeOfError} when it cannot compute the size. This + * function is architecture dependent, so you should only call this after you + * call {!Cil.initCIL}. Remember that on GCC sizeof(void) is 1! *) +val bitsSizeOf: typ -> int + +(* The size of a type, in bytes. Returns a constant expression or a "sizeof" + * expression if it cannot compute the size. This function is architecture + * dependent, so you should only call this after you call {!Cil.initCIL}. *) +val sizeOf: typ -> exp + +(** The minimum alignment (in bytes) for a type. This function is + * architecture dependent, so you should only call this after you call + * {!Cil.initCIL}. *) +val alignOf_int: typ -> int + +(** Give a type of a base and an offset, returns the number of bits from the + * base address and the width (also expressed in bits) for the subobject + * denoted by the offset. Raises {!Cil.SizeOfError} when it cannot compute + * the size. This function is architecture dependent, so you should only call + * this after you call {!Cil.initCIL}. *) +val bitsOffset: typ -> offset -> int * int + + +(** Whether "char" is unsigned. Set after you call {!Cil.initCIL} *) +val char_is_unsigned: bool ref + +(** Whether the machine is little endian. Set after you call {!Cil.initCIL} *) +val little_endian: bool ref + +(** Whether the compiler generates assembly labels by prepending "_" to the + identifier. That is, will function foo() have the label "foo", or "_foo"? + Set after you call {!Cil.initCIL} *) +val underscore_name: bool ref + +(** Represents a location that cannot be determined *) +val locUnknown: location + +(** Return the location of an instruction *) +val get_instrLoc: instr -> location + +(** Return the location of a global, or locUnknown *) +val get_globalLoc: global -> location + +(** Return the location of a statement, or locUnknown *) +val get_stmtLoc: stmtkind -> location + + +(** Generate an {!Cil.exp} to be used in case of errors. *) +val dExp: Pretty.doc -> exp + +(** Generate an {!Cil.instr} to be used in case of errors. *) +val dInstr: Pretty.doc -> location -> instr + +(** Generate a {!Cil.global} to be used in case of errors. *) +val dGlobal: Pretty.doc -> location -> global + +(** Like map but try not to make a copy of the list *) +val mapNoCopy: ('a -> 'a) -> 'a list -> 'a list + +(** Like map but each call can return a list. Try not to make a copy of the + list *) +val mapNoCopyList: ('a -> 'a list) -> 'a list -> 'a list + +(** sm: return true if the first is a prefix of the second string *) +val startsWith: string -> string -> bool + + +(** {b An Interpreter for constructing CIL constructs} *) + +(** The type of argument for the interpreter *) +type formatArg = + Fe of exp + | Feo of exp option (** For array lengths *) + | Fu of unop + | Fb of binop + | Fk of ikind + | FE of exp list (** For arguments in a function call *) + | Ff of (string * typ * attributes) (** For a formal argument *) + | FF of (string * typ * attributes) list (** For formal argument lists *) + | Fva of bool (** For the ellipsis in a function type *) + | Fv of varinfo + | Fl of lval + | Flo of lval option + + | Fo of offset + + | Fc of compinfo + | Fi of instr + | FI of instr list + | Ft of typ + | Fd of int + | Fg of string + | Fs of stmt + | FS of stmt list + | FA of attributes + + | Fp of attrparam + | FP of attrparam list + + | FX of string + + +(** Pretty-prints a format arg *) +val d_formatarg: unit -> formatArg -> Pretty.doc + +val lowerConstants: bool ref + (** Do lower constant expressions into constants (default true) *) diff --git a/cil/src/cillower.ml b/cil/src/cillower.ml new file mode 100755 index 0000000..61745bf --- /dev/null +++ b/cil/src/cillower.ml @@ -0,0 +1,57 @@ +(* + * + * Copyright (c) 2001-2003, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Ben Liblit + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(** A number of lowering passes over CIL *) +open Cil +open Pretty +module E = Errormsg + +(** Lower CEnum constants *) +class lowerEnumVisitorClass : cilVisitor = object (self) + inherit nopCilVisitor + + method vexpr (e: exp) = + match e with + Const (CEnum(v, s, ei)) -> + ChangeTo (visitCilExpr (self :>cilVisitor) v) + + | _ -> DoChildren + +end + +let lowerEnumVisitor = new lowerEnumVisitorClass diff --git a/cil/src/cillower.mli b/cil/src/cillower.mli new file mode 100755 index 0000000..a62c9e3 --- /dev/null +++ b/cil/src/cillower.mli @@ -0,0 +1,42 @@ +(* + * + * Copyright (c) 2001-2003, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Ben Liblit + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(** A number of lowering passes over CIL *) + +(** Replace enumeration constants with integer constants *) +val lowerEnumVisitor : Cil.cilVisitor diff --git a/cil/src/ciloptions.ml b/cil/src/ciloptions.ml new file mode 100755 index 0000000..9a2b4bd --- /dev/null +++ b/cil/src/ciloptions.ml @@ -0,0 +1,196 @@ +(* + * + * Copyright (c) 2001-2003, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Ben Liblit + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + +module E = Errormsg + +let setDebugFlag v name = + E.debugFlag := v; + if v then Pretty.flushOften := true + +type outfile = + { fname: string; + fchan: out_channel } + +let setTraceDepth n = + Pretty.printDepth := n + + + (* Processign of output file arguments *) +let openFile (what: string) (takeit: outfile -> unit) (fl: string) = + if !E.verboseFlag then + ignore (Printf.printf "Setting %s to %s\n" what fl); + (try takeit { fname = fl; + fchan = open_out fl } + with _ -> + raise (Arg.Bad ("Cannot open " ^ what ^ " file " ^ fl))) + + +let fileNames : string list ref = ref [] +let recordFile fname = + fileNames := fname :: (!fileNames) + + (* Parsing of files with additional names *) +let parseExtraFile (s: string) = + try + let sfile = open_in s in + while true do + let line = try input_line sfile with e -> (close_in sfile; raise e) in + let linelen = String.length line in + let rec scan (pos: int) (* next char to look at *) + (start: int) : unit (* start of the word, + or -1 if none *) = + if pos >= linelen then + if start >= 0 then + recordFile (String.sub line start (pos - start)) + else + () (* Just move on to the next line *) + else + let c = String.get line pos in + match c with + ' ' | '\n' | '\r' | '\t' -> + (* whitespace *) + if start >= 0 then begin + recordFile (String.sub line start (pos - start)); + end; + scan (pos + 1) (-1) + + | _ -> (* non-whitespace *) + if start >= 0 then + scan (pos + 1) start + else + scan (pos + 1) pos + in + scan 0 (-1) + done + with Sys_error _ -> E.s (E.error "Cannot find extra file: %s\n" s) + | End_of_file -> () + + +let options : (string * Arg.spec * string) list = + [ + (* General Options *) + "", Arg.Unit (fun () -> ()), "\n\t\tGeneral Options\n" ; + + "--version", Arg.Unit + (fun _ -> print_endline ("CIL version " ^ Cil.cilVersion ^ + "\nMore information at http://cil.sourceforge.net/\n"); + exit 0), + "output version information and exit"; + "--verbose", Arg.Unit (fun _ -> E.verboseFlag := true), + "Print lots of random stuff. This is passed on from cilly."; + "--warnall", Arg.Unit (fun _ -> E.warnFlag := true), "Show all warnings"; + "--debug", Arg.String (setDebugFlag true), + " turns on debugging flag xxx"; + "--nodebug", Arg.String (setDebugFlag false), + " turns off debugging flag xxx"; + + "--flush", Arg.Unit (fun _ -> Pretty.flushOften := true), + "Flush the output streams often (aids debugging)" ; + "--check", Arg.Unit (fun _ -> Cilutil.doCheck := true), + "Run a consistency check over the CIL after every operation."; + "--nocheck", Arg.Unit (fun _ -> Cilutil.doCheck := false), + "turns off consistency checking of CIL"; + "--noPrintLn", Arg.Unit (fun _ -> Cil.lineDirectiveStyle := None; + Cprint.printLn := false), + "Don't output #line directives in the output."; + "--commPrintLn", Arg.Unit (fun _ -> Cil.lineDirectiveStyle := Some Cil.LineComment; + Cprint.printLnComment := true), + "Print #line directives in the output, but put them in comments."; + "--stats", Arg.Unit (fun _ -> Cilutil.printStats := true), + "Print statistics about running times and memory usage."; + + + "--log", Arg.String (openFile "log" (fun oc -> E.logChannel := oc.fchan)), + "Set the name of the log file. By default stderr is used"; + + "--MSVC", Arg.Unit (fun _ -> Cil.msvcMode := true; + Frontc.setMSVCMode (); + if not Machdep.hasMSVC then + ignore (E.warn "Will work in MSVC mode but will be using machine-dependent parameters for GCC since you do not have the MSVC compiler installed\n") + ), "Enable MSVC compatibility. Default is GNU."; + + "--testcil", Arg.String (fun s -> Cilutil.testcil := s), + "test CIL using the given compiler"; + + "--ignore-merge-conflicts", + Arg.Unit (fun _ -> Mergecil.ignore_merge_conflicts := true), + "ignore merging conflicts"; + "--sliceGlobal", Arg.Unit (fun _ -> Cilutil.sliceGlobal := true), + "output is the slice of #pragma cilnoremove(sym) symbols"; + + (* sm: some more debugging options *) + "--tr", Arg.String Trace.traceAddMulti, + ": subsystem to show debug printfs for"; + "--pdepth", Arg.Int setTraceDepth, + ": set max print depth (default: 5)"; + + "--extrafiles", Arg.String parseExtraFile, + ": the name of a file that contains a list of additional files to process, separated by whitespace of newlines"; + + (* Lowering Options *) + "", Arg.Unit (fun () -> ()), "\n\t\tLowering Options\n" ; + + "--noLowerConstants", Arg.Unit (fun _ -> Cil.lowerConstants := false), + "do not lower constant expressions"; + + "--noInsertImplicitCasts", Arg.Unit (fun _ -> Cil.insertImplicitCasts := false), + "do not insert implicit casts"; + + "--forceRLArgEval", + Arg.Unit (fun n -> Cabs2cil.forceRLArgEval := true), + "Forces right to left evaluation of function arguments"; + "--nocil", Arg.Int (fun n -> Cabs2cil.nocil := n), + "Do not compile to CIL the global with the given index"; + "--disallowDuplication", Arg.Unit (fun n -> Cabs2cil.allowDuplication := false), + "Prevent small chunks of code from being duplicated"; + "--keepunused", Arg.Set Rmtmps.keepUnused, + "Do not remove the unused variables and types"; + "--rmUnusedInlines", Arg.Set Rmtmps.rmUnusedInlines, + "Delete any unused inline functions. This is the default in MSVC mode"; + + + + "", Arg.Unit (fun () -> ()), "\n\t\tOutput Options\n" ; + "--printCilAsIs", Arg.Unit (fun _ -> Cil.printCilAsIs := true), + "do not try to simplify the CIL when printing. Without this flag, CIL will attempt to produce prettier output by e.g. changing while(1) into more meaningful loops."; + "--noWrap", Arg.Unit (fun _ -> Cil.lineLength := 100000), + "do not wrap long lines when printing"; + + ] + diff --git a/cil/src/ciloptions.mli b/cil/src/ciloptions.mli new file mode 100755 index 0000000..13f65cf --- /dev/null +++ b/cil/src/ciloptions.mli @@ -0,0 +1,48 @@ +(* + * + * Copyright (c) 2001-2003, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Ben Liblit + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + +(** The command-line options for CIL *) +val options : (string * Arg.spec * string) list + + +(** The list of file names *) +val fileNames : string list ref + +(** Adds the file to the start of fileNames *) +val recordFile: string -> unit diff --git a/cil/src/cilutil.ml b/cil/src/cilutil.ml new file mode 100644 index 0000000..b9a4da9 --- /dev/null +++ b/cil/src/cilutil.ml @@ -0,0 +1,72 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* Keep here the globally-visible flags *) +let doCheck= ref false (* Whether to check CIL *) + +let logCalls = ref false (* Whether to produce a log with all the function + * calls made *) +let logWrites = ref false (* Whether to produce a log with all the mem + * writes made *) +let doPartial = ref false (* Whether to do partial evaluation and constant + * folding *) +let doSimpleMem = ref false (* reduce complex memory expressions so that + * they contain at most one lval *) +let doOneRet = ref false (* make a functions have at most one 'return' *) +let doStackGuard = ref false (* instrument function calls and returns to +maintain a separate stack for return addresses *) +let doHeapify = ref false (* move stack-allocated arrays to the heap *) +let makeCFG = ref false (* turn the input CIL file into something more like + * a CFG *) +let printStats = ref false + +(* when 'sliceGlobal' is set, then when 'rmtmps' runs, only globals*) +(* marked with #pragma cilnoremove(whatever) are kept; when used with *) +(* cilly.asm.exe, the effect is to slice the input on the noremove symbols *) +let sliceGlobal = ref false + + +let printStages = ref false + + +let doCxxPP = ref false + +let libDir = ref "" + +let dumpFCG = ref false +let testcil = ref "" + diff --git a/cil/src/escape.ml b/cil/src/escape.ml new file mode 100644 index 0000000..198c9e5 --- /dev/null +++ b/cil/src/escape.ml @@ -0,0 +1,93 @@ +(* + * + * Copyright (c) 2003, + * Ben Liblit + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + +(** OCaml types used to represent wide characters and strings *) +type wchar = int64 +type wstring = wchar list + + +let escape_char = function + | '\007' -> "\\a" + | '\b' -> "\\b" + | '\t' -> "\\t" + | '\n' -> "\\n" + | '\011' -> "\\v" + | '\012' -> "\\f" + | '\r' -> "\\r" + | '"' -> "\\\"" + | '\'' -> "\\'" + | '\\' -> "\\\\" + | ' ' .. '~' as printable -> String.make 1 printable + | unprintable -> Printf.sprintf "\\%03o" (Char.code unprintable) + +let escape_string str = + let length = String.length str in + let buffer = Buffer.create length in + for index = 0 to length - 1 do + Buffer.add_string buffer (escape_char (String.get str index)) + done; + Buffer.contents buffer + +(* a wide char represented as an int64 *) +let escape_wchar = + (* limit checks whether upper > probe *) + let limit upper probe = (Int64.to_float (Int64.sub upper probe)) > 0.5 in + let fits_byte = limit (Int64.of_int 0x100) in + let fits_octal_escape = limit (Int64.of_int 0o1000) in + let fits_universal_4 = limit (Int64.of_int 0x10000) in + let fits_universal_8 = limit (Int64.of_string "0x100000000") in + fun charcode -> + if fits_byte charcode then + escape_char (Char.chr (Int64.to_int charcode)) + else if fits_octal_escape charcode then + Printf.sprintf "\\%03Lo" charcode + else if fits_universal_4 charcode then + Printf.sprintf "\\u%04Lx" charcode + else if fits_universal_8 charcode then + Printf.sprintf "\\u%04Lx" charcode + else + invalid_arg "Cprint.escape_string_intlist" + +(* a wide string represented as a list of int64s *) +let escape_wstring (str : int64 list) = + let length = List.length str in + let buffer = Buffer.create length in + let append charcode = + let addition = escape_wchar charcode in + Buffer.add_string buffer addition + in + List.iter append str; + Buffer.contents buffer diff --git a/cil/src/escape.mli b/cil/src/escape.mli new file mode 100644 index 0000000..b932ef1 --- /dev/null +++ b/cil/src/escape.mli @@ -0,0 +1,48 @@ +(* + * + * Copyright (c) 2003, + * Ben Liblit + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* + * Character and string escaping utilities + *) + +(** OCaml types used to represent wide characters and strings *) +type wchar = int64 +type wstring = wchar list + +(** escape various constructs in accordance with C lexical rules *) +val escape_char : char -> string +val escape_string : string -> string +val escape_wchar : wchar -> string +val escape_wstring : wstring -> string diff --git a/cil/src/ext/astslicer.ml b/cil/src/ext/astslicer.ml new file mode 100644 index 0000000..ffba482 --- /dev/null +++ b/cil/src/ext/astslicer.ml @@ -0,0 +1,454 @@ +(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) + +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +open Cil +module E = Errormsg +(* + * Weimer: an AST Slicer for use in Daniel's Delta Debugging Algorithm. + *) +let debug = ref false + +(* + * This type encapsulates a mapping form program locations to names + * in our naming convention. + *) +type enumeration_info = { + statements : (stmt, string) Hashtbl.t ; + instructions : (instr, string) Hashtbl.t ; +} + +(********************************************************************** + * Enumerate 1 + * + * Given a cil file, enumerate all of the statement names in it using + * our naming scheme. + **********************************************************************) +let enumerate out (f : Cil.file) = + let st_ht = Hashtbl.create 32767 in + let in_ht = Hashtbl.create 32767 in + + let emit base i ht elt = + let str = Printf.sprintf "%s.%d" base !i in + Printf.fprintf out "%s\n" str ; + Hashtbl.add ht elt str ; + incr i + in + let emit_call base i str2 ht elt = + let str = Printf.sprintf "%s.%d" base !i in + Printf.fprintf out "%s - %s\n" str str2 ; + Hashtbl.add ht elt str ; + incr i + in + let descend base i = + let res = (Printf.sprintf "%s.%d" base !i),(ref 0) in + res + in + let rec doBlock b base i = + doStmtList b.bstmts base i + and doStmtList sl base i = + List.iter (fun s -> match s.skind with + | Instr(il) -> doIL il base i + | Return(_,_) + | Goto(_,_) + | Continue(_) + | Break(_) -> emit base i st_ht s + | If(e,b1,b2,_) -> + emit base i st_ht s ; + decr i ; + Printf.fprintf out "(\n" ; + let base',i' = descend base i in + doBlock b1 base' i' ; + Printf.fprintf out ") (\n" ; + let base'',i'' = descend base i in + doBlock b2 base'' i'' ; + Printf.fprintf out ")\n" ; + incr i + | Switch(_,b,_,_) +(* + | Loop(b,_,_,_) +*) + | While(_,b,_) + | DoWhile(_,b,_) + | For(_,_,_,b,_) + | Block(b) -> + emit base i st_ht s ; + decr i ; + let base',i' = descend base i in + Printf.fprintf out "(\n" ; + doBlock b base' i' ; + Printf.fprintf out ")\n" ; + incr i + | TryExcept _ | TryFinally _ -> + E.s (E.unimp "astslicer:enumerate") + ) sl + and doIL il base i = + List.iter (fun ins -> match ins with + | Set _ + | Asm _ -> emit base i in_ht ins + | Call(_,(Lval(Var(vi),NoOffset)),_,_) -> + emit_call base i vi.vname in_ht ins + | Call(_,f,_,_) -> emit_call base i "*" in_ht ins + ) il + in + let doGlobal g = match g with + | GFun(fd,_) -> + Printf.fprintf out "%s (\n" fd.svar.vname ; + let cur = ref 0 in + doBlock fd.sbody fd.svar.vname cur ; + Printf.fprintf out ")\n" ; + () + | _ -> () + in + List.iter doGlobal f.globals ; + { statements = st_ht ; + instructions = in_ht ; } + +(********************************************************************** + * Enumerate 2 + * + * Given a cil file and some enumeration information, do a log-calls-like + * transformation on it that prints out our names as you reach them. + **********************************************************************) +(* + * This is the visitor that handles annotations + *) +let print_it pfun name = + ((Call(None,Lval(Var(pfun),NoOffset), + [mkString (name ^ "\n")],locUnknown))) + +class enumVisitor pfun st_ht in_ht = object + inherit nopCilVisitor + method vinst i = + if Hashtbl.mem in_ht i then begin + let name = Hashtbl.find in_ht i in + let newinst = print_it pfun name in + ChangeTo([newinst ; i]) + end else + DoChildren + method vstmt s = + if Hashtbl.mem st_ht s then begin + let name = Hashtbl.find st_ht s in + let newinst = print_it pfun name in + let newstmt = mkStmtOneInstr newinst in + let newblock = mkBlock [newstmt ; s] in + let replace_with = mkStmt (Block(newblock)) in + ChangeDoChildrenPost(s,(fun i -> replace_with)) + end else + DoChildren + method vfunc f = + let newinst = print_it pfun f.svar.vname in + let newstmt = mkStmtOneInstr newinst in + let new_f = { f with sbody = { f.sbody with + bstmts = newstmt :: f.sbody.bstmts }} in + ChangeDoChildrenPost(new_f,(fun i -> i)) +end + +let annotate (f : Cil.file) ei = begin + (* Create a prototype for the logging function *) + let printfFun = + let fdec = emptyFunction "printf" in + let argf = makeLocalVar fdec "format" charConstPtrType in + fdec.svar.vtype <- TFun(intType, Some [ ("format", charConstPtrType, [])], + true, []); + fdec + in + let visitor = (new enumVisitor printfFun.svar ei.statements + ei.instructions) in + visitCilFileSameGlobals visitor f; + f +end + +(********************************************************************** + * STAGE 2 + * + * Perform a transitive-closure-like operation on the parts of the program + * that the user wants to keep. We use a CIL visitor to walk around + * and a number of hash tables to keep track of the things we want to keep. + **********************************************************************) +(* + * Hashtables: + * ws - wanted stmts + * wi - wanted instructions + * wt - wanted typeinfo + * wc - wanted compinfo + * we - wanted enuminfo + * wv - wanted varinfo + *) + +let mode = ref false (* was our parented wanted? *) +let finished = ref true (* set to false if we update something *) + +(* In the given hashtable, mark the given element was "wanted" *) +let update ht elt = + if Hashtbl.mem ht elt && (Hashtbl.find ht elt = true) then () + else begin + Hashtbl.add ht elt true ; + finished := false + end + +(* Handle a particular stage of the AST tree walk. Use "mode" (i.e., + * whether our parent was wanted) and the hashtable (which tells us whether + * the user had any special instructions for this element) to determine + * what do to. *) +let handle ht elt rep = + if !mode then begin + if Hashtbl.mem ht elt && (Hashtbl.find ht elt = false) then begin + (* our parent is Wanted but we were told to ignore this subtree, + * so we won't be wanted. *) + mode := false ; + ChangeDoChildrenPost(rep,(fun elt -> mode := true ; elt)) + end else begin + (* we were not told to ignore this subtree, and our parent is + * Wanted, so we will be Wanted too! *) + update ht elt ; + DoChildren + end + end else if Hashtbl.mem ht elt && (Hashtbl.find ht elt = true) then begin + (* our parent was not wanted but we were wanted, so turn the + * mode on for now *) + mode := true ; + ChangeDoChildrenPost(rep,(fun elt -> mode := false ; elt)) + end else + DoChildren + +let handle_no_default ht elt rep old_mode = + if Hashtbl.mem ht elt && (Hashtbl.find ht elt = true) then begin + (* our parent was not wanted but we were wanted, so turn the + * mode on for now *) + mode := true ; + ChangeDoChildrenPost(rep,(fun elt -> mode := old_mode ; elt)) + end else begin + mode := false ; + ChangeDoChildrenPost(rep,(fun elt -> mode := old_mode ; elt)) + end + +(* + * This is the visitor that handles elements (marks them as wanted) + *) +class transVisitor ws wi wt wc we wv = object + inherit nopCilVisitor + + method vvdec vi = handle_no_default wv vi vi !mode + method vvrbl vi = handle wv vi vi + method vinst i = handle wi i [i] + method vstmt s = handle ws s s + method vfunc f = handle wv f.svar f + method vglob g = begin + match g with + | GType(ti,_) -> handle wt ti [g] + | GCompTag(ci,_) + | GCompTagDecl(ci,_) -> handle wc ci [g] + | GEnumTag(ei,_) + | GEnumTagDecl(ei,_) -> handle we ei [g] + | GVarDecl(vi,_) + | GVar(vi,_,_) -> handle wv vi [g] + | GFun(f,_) -> handle wv f.svar [g] + | _ -> DoChildren + end + method vtype t = begin + match t with + | TNamed(ti,_) -> handle wt ti t + | TComp(ci,_) -> handle wc ci t + | TEnum(ei,_) -> handle we ei t + | _ -> DoChildren + end +end + +(********************************************************************** + * STAGE 3 + * + * Eliminate all of the elements from the program that are not marked + * "keep". + **********************************************************************) +(* + * This is the visitor that throws away elements + *) +let handle ht elt keep drop = + if (Hashtbl.mem ht elt) && (Hashtbl.find ht elt = true) then + (* DoChildren *) ChangeDoChildrenPost(keep,(fun a -> a)) + else + ChangeTo(drop) + +class dropVisitor ws wi wt wc we wv = object + inherit nopCilVisitor + + method vinst i = handle wi i [i] [] + method vstmt s = handle ws s s (mkStmt (Instr([]))) + method vglob g = begin + match g with + | GType(ti,_) -> handle wt ti [g] [] + | GCompTag(ci,_) + | GCompTagDecl(ci,_) -> handle wc ci [g] [] + | GEnumTag(ei,_) + | GEnumTagDecl(ei,_) -> handle we ei [g] [] + | GVarDecl(vi,_) + | GVar(vi,_,_) -> handle wv vi [g] [] + | GFun(f,l) -> + let new_locals = List.filter (fun vi -> + Hashtbl.mem wv vi && (Hashtbl.find wv vi = true)) f.slocals in + let new_fundec = { f with slocals = new_locals} in + handle wv f.svar [(GFun(new_fundec,l))] [] + | _ -> DoChildren + end +end + +(********************************************************************** + * STAGE 1 + * + * Mark up the file with user-given information about what to keep and + * what to drop. + **********************************************************************) +type mark = Wanted | Unwanted | Unspecified +(* Given a cil file and a list of strings, mark all of the given ASTSlicer + * points as wanted or unwanted. *) +let mark_file (f : Cil.file) (names : (string, mark) Hashtbl.t) = + let ws = Hashtbl.create 32767 in + let wi = Hashtbl.create 32767 in + let wt = Hashtbl.create 32767 in + let wc = Hashtbl.create 32767 in + let we = Hashtbl.create 32767 in + let wv = Hashtbl.create 32767 in + if !debug then Printf.printf "Applying user marks to file ...\n" ; + let descend base i = + let res = (Printf.sprintf "%s.%d" base !i),(ref 0) in + res + in + let check base i (default : mark) = + let str = Printf.sprintf "%s.%d" base !i in + if !debug then Printf.printf "Looking for [%s]\n" str ; + try Hashtbl.find names str + with _ -> default + in + let mark ht stmt wanted = match wanted with + Unwanted -> Hashtbl.replace ht stmt false + | Wanted -> Hashtbl.replace ht stmt true + | Unspecified -> () + in + let rec doBlock b base i default = + doStmtList b.bstmts base i default + and doStmtList sl base i default = + List.iter (fun s -> match s.skind with + | Instr(il) -> doIL il base i default + | Return(_,_) + | Goto(_,_) + | Continue(_) + | Break(_) -> + mark ws s (check base i default) ; incr i + | If(e,b1,b2,_) -> + let inside = check base i default in + mark ws s inside ; + let base',i' = descend base i in + doBlock b1 base' i' inside ; + let base'',i'' = descend base i in + doBlock b2 base'' i'' inside ; + incr i + | Switch(_,b,_,_) +(* + | Loop(b,_,_,_) +*) + | While(_,b,_) + | DoWhile(_,b,_) + | For(_,_,_,b,_) + | Block(b) -> + let inside = check base i default in + mark ws s inside ; + let base',i' = descend base i in + doBlock b base' i' inside ; + incr i + | TryExcept _ | TryFinally _ -> + E.s (E.unimp "astslicer: mark") + ) sl + and doIL il base i default = + List.iter (fun ins -> mark wi ins (check base i default) ; incr i) il + in + let doGlobal g = match g with + | GFun(fd,_) -> + let cur = ref 0 in + if Hashtbl.mem names fd.svar.vname then begin + if Hashtbl.find names fd.svar.vname = Wanted then begin + Hashtbl.replace wv fd.svar true ; + doBlock fd.sbody fd.svar.vname cur (Wanted); + end else begin + Hashtbl.replace wv fd.svar false ; + doBlock fd.sbody fd.svar.vname cur (Unspecified); + end + end else begin + doBlock fd.sbody fd.svar.vname cur (Unspecified); + end + | _ -> () + in + List.iter doGlobal f.globals ; + if !debug then begin + Hashtbl.iter (fun k v -> + ignore (Pretty.printf "want-s %b %a\n" v d_stmt k)) ws ; + Hashtbl.iter (fun k v -> + ignore (Pretty.printf "want-i %b %a\n" v d_instr k)) wi ; + Hashtbl.iter (fun k v -> + ignore (Pretty.printf "want-v %b %s\n" v k.vname)) wv ; + end ; + (* + * Now repeatedly mark all other things that must be kept. + *) + let visitor = (new transVisitor ws wi wt wc we wv) in + finished := false ; + if !debug then (Printf.printf "\nPerforming Transitive Closure\n\n" ); + while not !finished do + finished := true ; + visitCilFileSameGlobals visitor f + done ; + if !debug then begin + Hashtbl.iter (fun k v -> + if v then ignore (Pretty.printf "want-s %a\n" d_stmt k)) ws ; + Hashtbl.iter (fun k v -> + if v then ignore (Pretty.printf "want-i %a\n" d_instr k)) wi ; + Hashtbl.iter (fun k v -> + if v then ignore (Pretty.printf "want-t %s\n" k.tname)) wt ; + Hashtbl.iter (fun k v -> + if v then ignore (Pretty.printf "want-c %s\n" k.cname)) wc ; + Hashtbl.iter (fun k v -> + if v then ignore (Pretty.printf "want-e %s\n" k.ename)) we ; + Hashtbl.iter (fun k v -> + if v then ignore (Pretty.printf "want-v %s\n" k.vname)) wv ; + end ; + + (* + * Now drop everything we didn't need. + *) + if !debug then (Printf.printf "Dropping Unwanted Elements\n" ); + let visitor = (new dropVisitor ws wi wt wc we wv) in + visitCilFile visitor f diff --git a/cil/src/ext/availexps.ml b/cil/src/ext/availexps.ml new file mode 100644 index 0000000..28c22c0 --- /dev/null +++ b/cil/src/ext/availexps.ml @@ -0,0 +1,359 @@ +(* compute available expressions, although in a somewhat + non-traditional way. the abstract state is a mapping from + variable ids to expressions as opposed to a set of + expressions *) + +open Cil +open Pretty + +module E = Errormsg +module DF = Dataflow +module UD = Usedef +module IH = Inthash +module U = Util +module S = Stats + +let debug = ref false + +(* exp IH.t -> exp IH.t -> bool *) +let eh_equals eh1 eh2 = + if not(IH.length eh1 = IH.length eh2) + then false + else IH.fold (fun vid e b -> + if not b then b else + try let e2 = IH.find eh2 vid in + if not(Util.equals e e2) + then false + else true + with Not_found -> false) + eh1 true + +let eh_pretty () eh = line ++ seq line (fun (vid,e) -> + text "AE:vid:" ++ num vid ++ text ": " ++ + (d_exp () e)) (IH.tolist eh) + +(* the result must be the intersection of eh1 and eh2 *) +(* exp IH.t -> exp IH.t -> exp IH.t *) +let eh_combine eh1 eh2 = + if !debug then ignore(E.log "eh_combine: combining %a\n and\n %a\n" + eh_pretty eh1 eh_pretty eh2); + let eh' = IH.copy eh1 in (* eh' gets all of eh1 *) + IH.iter (fun vid e1 -> + try let e2l = IH.find_all eh2 vid in + if not(List.exists (fun e2 -> Util.equals e1 e2) e2l) + (* remove things from eh' that eh2 doesn't have *) + then let e1l = IH.find_all eh' vid in + let e1l' = List.filter (fun e -> not(Util.equals e e1)) e1l in + IH.remove_all eh' vid; + List.iter (fun e -> IH.add eh' vid e) e1l' + with Not_found -> + IH.remove_all eh' vid) eh1; + if !debug then ignore(E.log "with result %a\n" + eh_pretty eh'); + eh' + +(* On a memory write, kill expressions containing memory writes + * or variables whose address has been taken. *) +let exp_ok = ref false +class memReadOrAddrOfFinderClass = object(self) + inherit nopCilVisitor + + method vexpr e = match e with + Lval(Mem _, _) -> + exp_ok := true; + SkipChildren + | _ -> DoChildren + + method vvrbl vi = + if vi.vaddrof then + (exp_ok := true; + SkipChildren) + else DoChildren + +end + +let memReadOrAddrOfFinder = new memReadOrAddrOfFinderClass + +(* exp -> bool *) +let exp_has_mem_read e = + exp_ok := false; + ignore(visitCilExpr memReadOrAddrOfFinder e); + !exp_ok + +let eh_kill_mem eh = + IH.iter (fun vid e -> + if exp_has_mem_read e + then IH.remove eh vid) + eh + +(* need to kill exps containing a particular vi sometimes *) +let has_vi = ref false +class viFinderClass vi = object(self) + inherit nopCilVisitor + + method vvrbl vi' = + if vi.vid = vi'.vid + then (has_vi := true; SkipChildren) + else DoChildren + +end + +let exp_has_vi e vi = + let vis = new viFinderClass vi in + has_vi := false; + ignore(visitCilExpr vis e); + !has_vi + +let eh_kill_vi eh vi = + IH.iter (fun vid e -> + if exp_has_vi e vi + then IH.remove eh vid) + eh + +let varHash = IH.create 32 + +let eh_kill_addrof_or_global eh = + if !debug then ignore(E.log "eh_kill: in eh_kill\n"); + IH.iter (fun vid e -> + try let vi = IH.find varHash vid in + if vi.vaddrof + then begin + if !debug then ignore(E.log "eh_kill: %s has its address taken\n" + vi.vname); + IH.remove eh vid + end + else if vi.vglob + then begin + if !debug then ignore(E.log "eh_kill: %s is global\n" + vi.vname); + IH.remove eh vid + end + with Not_found -> ()) eh + +let eh_handle_inst i eh = match i with + (* if a pointer write, kill things with read in them. + also kill mappings from vars that have had their address taken, + and globals. + otherwise kill things with lv in them and add e *) + Set(lv,e,_) -> (match lv with + (Mem _, _) -> + (eh_kill_mem eh; + eh_kill_addrof_or_global eh; + eh) + | (Var vi, NoOffset) -> + (match e with + Lval(Var vi', NoOffset) -> (* ignore x = x *) + if vi'.vid = vi.vid then eh else + (IH.replace eh vi.vid e; + eh_kill_vi eh vi; + eh) + | _ -> + (IH.replace eh vi.vid e; + eh_kill_vi eh vi; + eh)) + | _ -> eh) (* do nothing for now. *) +| Call(Some(Var vi,NoOffset),_,_,_) -> + (IH.remove eh vi.vid; + eh_kill_vi eh vi; + eh_kill_mem eh; + eh_kill_addrof_or_global eh; + eh) +| Call(_,_,_,_) -> + (eh_kill_mem eh; + eh_kill_addrof_or_global eh; + eh) +| Asm(_,_,_,_,_,_) -> + let _,d = UD.computeUseDefInstr i in + (UD.VS.iter (fun vi -> + eh_kill_vi eh vi) d; + eh) + +let allExpHash = IH.create 128 + +module AvailableExps = + struct + + let name = "Available Expressions" + + let debug = debug + + (* mapping from var id to expression *) + type t = exp IH.t + + let copy = IH.copy + + let stmtStartData = IH.create 64 + + let pretty = eh_pretty + + let computeFirstPredecessor stm eh = + eh_combine (IH.copy allExpHash) eh + + let combinePredecessors (stm:stmt) ~(old:t) (eh:t) = + if S.time "eh_equals" (eh_equals old) eh then None else + Some(S.time "eh_combine" (eh_combine old) eh) + + let doInstr i eh = + let action = eh_handle_inst i in + DF.Post(action) + + let doStmt stm astate = DF.SDefault + + let doGuard c astate = DF.GDefault + + let filterStmt stm = true + + end + +module AE = DF.ForwardsDataFlow(AvailableExps) + +(* make an exp IH.t with everything in it, + * also, fill in varHash while we're here. + *) +class expCollectorClass = object(self) + inherit nopCilVisitor + + method vinst i = match i with + Set((Var vi,NoOffset),e,_) -> + let e2l = IH.find_all allExpHash vi.vid in + if not(List.exists (fun e2 -> Util.equals e e2) e2l) + then IH.add allExpHash vi.vid e; + DoChildren + | _ -> DoChildren + + method vvrbl vi = + (if not(IH.mem varHash vi.vid) + then + (if !debug && vi.vglob then ignore(E.log "%s is global\n" vi.vname); + if !debug && not(vi.vglob) then ignore(E.log "%s is not global\n" vi.vname); + IH.add varHash vi.vid vi)); + DoChildren + +end + +let expCollector = new expCollectorClass + +let make_all_exps fd = + IH.clear allExpHash; + IH.clear varHash; + ignore(visitCilFunction expCollector fd) + + + +(* set all statement data to allExpHash, make + * a list of statements + *) +let all_stmts = ref [] +class allExpSetterClass = object(self) + inherit nopCilVisitor + + method vstmt s = + all_stmts := s :: (!all_stmts); + IH.add AvailableExps.stmtStartData s.sid (IH.copy allExpHash); + DoChildren + +end + +let allExpSetter = new allExpSetterClass + +let set_all_exps fd = + IH.clear AvailableExps.stmtStartData; + ignore(visitCilFunction allExpSetter fd) + +(* + * Computes AEs for function fd. + * + * + *) +(*let iAEsHtbl = Hashtbl.create 128*) +let computeAEs fd = + try let slst = fd.sbody.bstmts in + let first_stm = List.hd slst in + S.time "make_all_exps" make_all_exps fd; + all_stmts := []; + (*S.time "set_all_exps" set_all_exps fd;*) + (*Hashtbl.clear iAEsHtbl;*) + (*IH.clear (IH.find AvailableExps.stmtStartData first_stm.sid);*) + IH.add AvailableExps.stmtStartData first_stm.sid (IH.create 4); + S.time "compute" AE.compute [first_stm](*(List.rev !all_stmts)*) + with Failure "hd" -> if !debug then ignore(E.log "fn w/ no stmts?\n") + | Not_found -> if !debug then ignore(E.log "no data for first_stm?\n") + + +(* get the AE data for a statement *) +let getAEs sid = + try Some(IH.find AvailableExps.stmtStartData sid) + with Not_found -> None + +(* get the AE data for an instruction list *) +let instrAEs il sid eh out = + (*if Hashtbl.mem iAEsHtbl (sid,out) + then Hashtbl.find iAEsHtbl (sid,out) + else*) + let proc_one hil i = + match hil with + [] -> let eh' = IH.copy eh in + let eh'' = eh_handle_inst i eh' in + (*if !debug then ignore(E.log "instrAEs: proc_one []: for %a\n data is %a\n" + d_instr i eh_pretty eh'');*) + eh''::hil + | eh'::ehrst as l -> + let eh' = IH.copy eh' in + let eh'' = eh_handle_inst i eh' in + (*if !debug then ignore(E.log "instrAEs: proc_one: for %a\n data is %a\n" + d_instr i eh_pretty eh'');*) + eh''::l + in + let folded = List.fold_left proc_one [eh] il in + (*let foldedout = List.tl (List.rev folded) in*) + let foldednotout = List.rev (List.tl folded) in + (*Hashtbl.add iAEsHtbl (sid,true) foldedout; + Hashtbl.add iAEsHtbl (sid,false) foldednotout;*) + (*if out then foldedout else*) foldednotout + +class aeVisitorClass = object(self) + inherit nopCilVisitor + + val mutable sid = -1 + + val mutable ae_dat_lst = [] + + val mutable cur_ae_dat = None + + method vstmt stm = + sid <- stm.sid; + match getAEs sid with + None -> + if !debug then ignore(E.log "aeVis: stm %d has no data\n" sid); + cur_ae_dat <- None; + DoChildren + | Some eh -> + match stm.skind with + Instr il -> + if !debug then ignore(E.log "aeVist: visit il\n"); + ae_dat_lst <- S.time "instrAEs" (instrAEs il stm.sid eh) false; + DoChildren + | _ -> + if !debug then ignore(E.log "aeVisit: visit non-il\n"); + cur_ae_dat <- None; + DoChildren + + method vinst i = + if !debug then ignore(E.log "aeVist: before %a, ae_dat_lst is %d long\n" + d_instr i (List.length ae_dat_lst)); + try + let data = List.hd ae_dat_lst in + cur_ae_dat <- Some(data); + ae_dat_lst <- List.tl ae_dat_lst; + if !debug then ignore(E.log "aeVisit: data is %a\n" eh_pretty data); + DoChildren + with Failure "hd" -> + if !debug then ignore(E.log "aeVis: il ae_dat_lst mismatch\n"); + DoChildren + + method get_cur_eh () = + match cur_ae_dat with + None -> getAEs sid + | Some eh -> Some eh + +end diff --git a/cil/src/ext/bitmap.ml b/cil/src/ext/bitmap.ml new file mode 100644 index 0000000..da1f8b9 --- /dev/null +++ b/cil/src/ext/bitmap.ml @@ -0,0 +1,224 @@ + + (* Imperative bitmaps *) +type t = { mutable nrWords : int; + mutable nrBits : int; (* This is 31 * nrWords *) + mutable bitmap : int array } + + + (* Enlarge a bitmap to contain at + * least newBits *) +let enlarge b newWords = + let newbitmap = + if newWords > b.nrWords then + let a = Array.create newWords 0 in + Array.blit b.bitmap 0 a 0 b.nrWords; + a + else + b.bitmap in + b.nrWords <- newWords; + b.nrBits <- (newWords lsl 5) - newWords; + b.bitmap <- newbitmap + + + (* Create a new empty bitmap *) +let make size = + let wrd = (size + 30) / 31 in + { nrWords = wrd; + nrBits = (wrd lsl 5) - wrd; + bitmap = Array.make wrd 0 + } + +let size t = t.nrBits + (* Make an initialized array *) +let init size how = + let wrd = (size + 30) / 31 in + let how' w = + let first = (w lsl 5) - w in + let last = min size (first + 31) in + let rec loop i acc = + if i >= last then acc + else + let acc' = acc lsl 1 in + if how i then loop (i + 1) (acc' lor 1) + else loop (i + 1) acc' + in + loop first 0 + in + { nrWords = wrd; + nrBits = (wrd lsl 5) - wrd; + bitmap = Array.init wrd how' + } + +let clone b = + { nrWords = b.nrWords; + nrBits = b.nrBits; + bitmap = Array.copy b.bitmap; + } + +let cloneEmpty b = + { nrWords = b.nrWords; + nrBits = b.nrBits; + bitmap = Array.make b.nrWords 0; + } + +let union b1 b2 = + begin + let n = b2.nrWords in + if b1.nrWords < n then enlarge b1 n else (); + let a1 = b1.bitmap in + let a2 = b2.bitmap in + let changed = ref false in + for i=0 to n - 1 do + begin + let t = a1.(i) in + let upd = t lor a2.(i) in + let _ = if upd <> t then changed := true else () in + Array.unsafe_set a1 i upd + end + done; + ! changed + end + (* lin += (lout - def) *) +let accLive lin lout def = + begin (* Need to enlarge def to lout *) + let n = lout.nrWords in + if def.nrWords < n then enlarge def n else (); + (* Need to enlarge lin to lout *) + if lin.nrWords < n then enlarge lin n else (); + let changed = ref false in + let alin = lin.bitmap in + let alout = lout.bitmap in + let adef = def.bitmap in + for i=0 to n - 1 do + begin + let old = alin.(i) in + let nw = old lor (alout.(i) land (lnot adef.(i))) in + alin.(i) <- nw; + changed := (old <> nw) || (!changed) + end + done; + !changed + end + + (* b1 *= b2 *) +let inters b1 b2 = + begin + let n = min b1.nrWords b2.nrWords in + let a1 = b1.bitmap in + let a2 = b2.bitmap in + for i=0 to n - 1 do + begin + a1.(i) <- a1.(i) land a2.(i) + end + done; + if n < b1.nrWords then + Array.fill a1 n (b1.nrWords - n) 0 + else + () + end + +let emptyInt b start = + let n = b.nrWords in + let a = b.bitmap in + let rec loop i = i >= n || (a.(i) = 0 && loop (i + 1)) + in + loop start + +let empty b = emptyInt b 0 + + (* b1 =? b2 *) +let equal b1 b2 = + begin + let n = min b1.nrWords b2.nrWords in + let a1 = b1.bitmap in + let a2 = b2.bitmap in + let res = ref true in + for i=0 to n - 1 do + begin + if a1.(i) != a2.(i) then res := false else () + end + done; + if !res then + if b1.nrWords > n then + emptyInt b1 n + else if b2.nrWords > n then + emptyInt b2 n + else + true + else + false + end + +let assign b1 b2 = + begin + let n = b2.nrWords in + if b1.nrWords < n then enlarge b1 n else (); + let a1 = b1.bitmap in + let a2 = b2.bitmap in + Array.blit a2 0 a1 0 n + end + + (* b1 -= b2 *) +let diff b1 b2 = + begin + let n = min b1.nrWords b2.nrWords in + let a1 = b1.bitmap in + let a2 = b2.bitmap in + for i=0 to n - 1 do + a1.(i) <- a1.(i) land (lnot a2.(i)) + done; + if n < b1.nrWords then + Array.fill a1 n (b1.nrWords - n) 0 + else + () + end + + + + +let get bmp i = + assert (i >= 0); + if i >= bmp.nrBits then enlarge bmp (i / 31 + 1) else (); + let wrd = i / 31 in + let msk = 1 lsl (i + wrd - (wrd lsl 5)) in + bmp.bitmap.(wrd) land msk != 0 + + +let set bmp i tv = + assert(i >= 0); + let wrd = i / 31 in + let msk = 1 lsl (i + wrd - (wrd lsl 5)) in + if i >= bmp.nrBits then enlarge bmp (wrd + 1) else (); + if tv then + bmp.bitmap.(wrd) <- bmp.bitmap.(wrd) lor msk + else + bmp.bitmap.(wrd) <- bmp.bitmap.(wrd) land (lnot msk) + + + + (* Iterate over all elements in a + * bitmap *) +let fold f bmp arg = + let a = bmp.bitmap in + let n = bmp.nrWords in + let rec allWords i bit arg = + if i >= n then + arg + else + let rec allBits msk bit left arg = + if left = 0 then + allWords (i + 1) bit arg + else + allBits ((lsr) msk 1) (bit + 1) (left - 1) + (if (land) msk 1 != 0 then f arg bit else arg) + in + allBits a.(i) bit 31 arg + in + allWords 0 0 arg + + +let iter f t = fold (fun x y -> f y) t () + +let toList bmp = fold (fun acc i -> i :: acc) bmp [] + +let card bmp = fold (fun acc _ -> acc + 1) bmp 0 diff --git a/cil/src/ext/bitmap.mli b/cil/src/ext/bitmap.mli new file mode 100644 index 0000000..5247e35 --- /dev/null +++ b/cil/src/ext/bitmap.mli @@ -0,0 +1,50 @@ + + (* Imperative bitmaps *) + +type t + (* Create a bitmap given the number + * of bits *) +val make : int -> t +val init : int -> (int -> bool) -> t (* Also initialize it *) + +val size : t -> int (* How much space it is reserved *) + + (* The cardinality of a set *) +val card : t -> int + + (* Make a copy of a bitmap *) +val clone : t -> t + +val cloneEmpty : t -> t (* An empty set with the same + * dimentions *) + +val set : t -> int -> bool -> unit +val get : t -> int -> bool + (* destructive union. The first + * element is updated. Returns true + * if any change was actually + * necessary *) +val union : t -> t -> bool + + (* accLive livein liveout def. Does + * liveIn += (liveout - def) *) +val accLive : t -> t -> t -> bool + + (* Copy the second argument onto the + * first *) +val assign : t -> t -> unit + + +val inters : t -> t -> unit +val diff : t -> t -> unit + + +val empty : t -> bool + +val equal : t -> t -> bool + +val toList : t -> int list + +val iter : (int -> unit) -> t -> unit +val fold : ('a -> int -> 'a) -> t -> 'a -> 'a + diff --git a/cil/src/ext/blockinggraph.ml b/cil/src/ext/blockinggraph.ml new file mode 100644 index 0000000..281678a --- /dev/null +++ b/cil/src/ext/blockinggraph.ml @@ -0,0 +1,769 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +open Cil +open Pretty +module E = Errormsg + +let debug = false + +let fingerprintAll = true + + +type blockkind = + NoBlock + | BlockTrans + | BlockPoint + | EndPoint + +(* For each function we have a node *) +type node = +{ + nodeid: int; + name: string; + mutable scanned: bool; + mutable expand: bool; + mutable fptr: bool; + mutable stacksize: int; + mutable fds: fundec option; + mutable bkind: blockkind; + mutable origkind: blockkind; + mutable preds: node list; + mutable succs: node list; + mutable predstmts: (stmt * node) list; +} + +type blockpt = +{ + id: int; + point: stmt; + callfun: string; + infun: string; + mutable leadsto: blockpt list; +} + + +(* Fresh ids for each node. *) +let curNodeNum : int ref = ref 0 +let getFreshNodeNum () : int = + let num = !curNodeNum in + incr curNodeNum; + num + +(* Initialize a node. *) +let newNode (name: string) (fptr: bool) (mangle: bool) : node = + let id = getFreshNodeNum () in + { nodeid = id; name = if mangle then name ^ (string_of_int id) else name; + scanned = false; expand = false; + fptr = fptr; stacksize = 0; fds = None; + bkind = NoBlock; origkind = NoBlock; + preds = []; succs = []; predstmts = []; } + + +(* My type signature ignores attributes and function pointers. *) +let myTypeSig (t: typ) : typsig = + let rec removeFunPtrs (ts: typsig) : typsig = + match ts with + TSPtr (TSFun _, a) -> + TSPtr (TSBase voidType, a) + | TSPtr (base, a) -> + TSPtr (removeFunPtrs base, a) + | TSArray (base, e, a) -> + TSArray (removeFunPtrs base, e, a) + | TSFun (ret, args, v, a) -> + TSFun (removeFunPtrs ret, List.map removeFunPtrs args, v, a) + | _ -> ts + in + removeFunPtrs (typeSigWithAttrs (fun _ -> []) t) + + +(* We add a dummy function whose name is "@@functionPointer@@" that is called + * at all invocations of function pointers and itself calls all functions + * whose address is taken. *) +let functionPointerName = "@@functionPointer@@" + +(* We map names to nodes *) +let functionNodes: (string, node) Hashtbl.t = Hashtbl.create 113 +let getFunctionNode (n: string) : node = + Util.memoize + functionNodes + n + (fun _ -> newNode n false false) + +(* We map types to nodes for function pointers *) +let functionPtrNodes: (typsig, node) Hashtbl.t = Hashtbl.create 113 +let getFunctionPtrNode (t: typ) : node = + Util.memoize + functionPtrNodes + (myTypeSig t) + (fun _ -> newNode functionPointerName true true) + +let startNode: node = newNode "@@startNode@@" true false + + +(* +(** Dump the function call graph. *) +let dumpFunctionCallGraph (start: node) = + Hashtbl.iter (fun _ x -> x.scanned <- false) functionNodes; + let rec dumpOneNode (ind: int) (n: node) : unit = + output_string !E.logChannel "\n"; + for i = 0 to ind do + output_string !E.logChannel " " + done; + output_string !E.logChannel (n.name ^ " "); + begin + match n.bkind with + NoBlock -> () + | BlockTrans -> output_string !E.logChannel " " + | BlockPoint -> output_string !E.logChannel " " + | EndPoint -> output_string !E.logChannel " " + end; + if n.scanned then (* Already dumped *) + output_string !E.logChannel " " + else begin + n.scanned <- true; + List.iter (fun n -> if n.bkind <> EndPoint then dumpOneNode (ind + 1) n) + n.succs + end + in + dumpOneNode 0 start; + output_string !E.logChannel "\n\n" +*) + +let dumpFunctionCallGraphToFile () = + let channel = open_out "graph" in + let dumpNode _ (n: node) : unit = + let first = ref true in + let dumpSucc (n: node) : unit = + if !first then + first := false + else + output_string channel ","; + output_string channel n.name + in + output_string channel (string_of_int n.nodeid); + output_string channel ":"; + output_string channel (string_of_int n.stacksize); + output_string channel ":"; + if n.fds = None && not n.fptr then + output_string channel "x"; + output_string channel ":"; + output_string channel n.name; + output_string channel ":"; + List.iter dumpSucc n.succs; + output_string channel "\n"; + in + dumpNode () startNode; + Hashtbl.iter dumpNode functionNodes; + Hashtbl.iter dumpNode functionPtrNodes; + close_out channel + + +let addCall (callerNode: node) (calleeNode: node) (sopt: stmt option) = + if not (List.exists (fun n -> n.name = calleeNode.name) + callerNode.succs) then begin + if debug then + ignore (E.log "found call from %s to %s\n" + callerNode.name calleeNode.name); + callerNode.succs <- calleeNode :: callerNode.succs; + calleeNode.preds <- callerNode :: calleeNode.preds; + end; + match sopt with + Some s -> + if not (List.exists (fun (s', _) -> s' = s) calleeNode.predstmts) then + calleeNode.predstmts <- (s, callerNode) :: calleeNode.predstmts + | None -> () + + +class findCallsVisitor (host: node) : cilVisitor = object + inherit nopCilVisitor + + val mutable curStmt : stmt ref = ref (mkEmptyStmt ()) + + method vstmt s = + curStmt := s; + DoChildren + + method vinst i = + match i with + | Call(_,Lval(Var(vi),NoOffset),args,l) -> + addCall host (getFunctionNode vi.vname) (Some !curStmt); + SkipChildren + + | Call(_,e,_,l) -> (* Calling a function pointer *) + addCall host (getFunctionPtrNode (typeOf e)) (Some !curStmt); + SkipChildren + + | _ -> SkipChildren (* No calls in other instructions *) + + (* There are no calls in expressions and types *) + method vexpr e = SkipChildren + method vtype t = SkipChildren + +end + + +let endPt = { id = 0; point = mkEmptyStmt (); callfun = "end"; infun = "end"; + leadsto = []; } + +(* These values will be initialized for real in makeBlockingGraph. *) +let curId : int ref = ref 1 +let startName : string ref = ref "" +let blockingPoints : blockpt list ref = ref [] +let blockingPointsNew : blockpt Queue.t = Queue.create () +let blockingPointsHash : (int, blockpt) Hashtbl.t = Hashtbl.create 113 + +let getFreshNum () : int = + let num = !curId in + curId := !curId + 1; + num + +let getBlockPt (s: stmt) (cfun: string) (ifun: string) : blockpt = + try + Hashtbl.find blockingPointsHash s.sid + with Not_found -> + let num = getFreshNum () in + let bpt = { id = num; point = s; callfun = cfun; infun = ifun; + leadsto = []; } in + Hashtbl.add blockingPointsHash s.sid bpt; + blockingPoints := bpt :: !blockingPoints; + Queue.add bpt blockingPointsNew; + bpt + + +type action = + Process of stmt * node + | Next of stmt * node + | Return of node + +let getStmtNode (s: stmt) : node option = + match s.skind with + Instr instrs -> begin + let len = List.length instrs in + if len > 0 then + match List.nth instrs (len - 1) with + Call (_, Lval (Var vi, NoOffset), args, _) -> + Some (getFunctionNode vi.vname) + | Call (_, e, _, _) -> (* Calling a function pointer *) + Some (getFunctionPtrNode (typeOf e)) + | _ -> + None + else + None + end + | _ -> None + +let addBlockingPointEdge (bptFrom: blockpt) (bptTo: blockpt) : unit = + if not (List.exists (fun bpt -> bpt = bptTo) bptFrom.leadsto) then + bptFrom.leadsto <- bptTo :: bptFrom.leadsto + +let findBlockingPointEdges (bpt: blockpt) : unit = + let seenStmts = Hashtbl.create 117 in + let worklist = Queue.create () in + Queue.add (Next (bpt.point, getFunctionNode bpt.infun)) worklist; + while Queue.length worklist > 0 do + let act = Queue.take worklist in + match act with + Process (curStmt, curNode) -> begin + Hashtbl.add seenStmts curStmt.sid (); + match getStmtNode curStmt with + Some node -> begin + if debug then + ignore (E.log "processing node %s\n" node.name); + match node.bkind with + NoBlock -> + Queue.add (Next (curStmt, curNode)) worklist + | BlockTrans -> begin + let processFundec (fd: fundec) : unit = + let s = List.hd fd.sbody.bstmts in + if not (Hashtbl.mem seenStmts s.sid) then + let n = getFunctionNode fd.svar.vname in + Queue.add (Process (s, n)) worklist + in + match node.fds with + Some fd -> + processFundec fd + | None -> + List.iter + (fun n -> + match n.fds with + Some fd -> processFundec fd + | None -> E.s (bug "expected fundec")) + node.succs + end + | BlockPoint -> + addBlockingPointEdge bpt + (getBlockPt curStmt node.name curNode.name) + | EndPoint -> + addBlockingPointEdge bpt endPt + end + | _ -> + Queue.add (Next (curStmt, curNode)) worklist + end + | Next (curStmt, curNode) -> begin + match curStmt.Cil.succs with + [] -> + if debug then + ignore (E.log "hit end of %s\n" curNode.name); + Queue.add (Return curNode) worklist + | _ -> + List.iter (fun s -> + if not (Hashtbl.mem seenStmts s.sid) then + Queue.add (Process (s, curNode)) worklist) + curStmt.Cil.succs + end + | Return curNode when curNode.bkind = NoBlock -> + () + | Return curNode when curNode.name = !startName -> + addBlockingPointEdge bpt endPt + | Return curNode -> + List.iter (fun (s, n) -> if n.bkind <> NoBlock then + Queue.add (Next (s, n)) worklist) + curNode.predstmts; + List.iter (fun n -> if n.fptr then + Queue.add (Return n) worklist) + curNode.preds + done + +let markYieldPoints (n: node) : unit = + let rec markNode (n: node) : unit = + if n.bkind = NoBlock then + match n.origkind with + BlockTrans -> + if n.expand || n.fptr then begin + n.bkind <- BlockTrans; + List.iter markNode n.succs + end else begin + n.bkind <- BlockPoint + end + | _ -> + n.bkind <- n.origkind + in + Hashtbl.iter (fun _ n -> n.bkind <- NoBlock) functionNodes; + Hashtbl.iter (fun _ n -> n.bkind <- NoBlock) functionPtrNodes; + markNode n + +let makeBlockingGraph (start: node) = + let startStmt = + match start.fds with + Some fd -> List.hd fd.sbody.bstmts + | None -> E.s (bug "expected fundec") + in + curId := 1; + startName := start.name; + blockingPoints := [endPt]; + Queue.clear blockingPointsNew; + Hashtbl.clear blockingPointsHash; + ignore (getBlockPt startStmt start.name start.name); + while Queue.length blockingPointsNew > 0 do + let bpt = Queue.take blockingPointsNew in + findBlockingPointEdges bpt; + done + +let dumpBlockingGraph () = + List.iter + (fun bpt -> + if bpt.id < 2 then begin + ignore (E.log "bpt %d (%s): " bpt.id bpt.callfun) + end else begin + ignore (E.log "bpt %d (%s in %s): " bpt.id bpt.callfun bpt.infun) + end; + List.iter (fun bpt -> ignore (E.log "%d " bpt.id)) bpt.leadsto; + ignore (E.log "\n")) + !blockingPoints; + ignore (E.log "\n") + +let beforeFun = + makeGlobalVar "before_bg_node" + (TFun (voidType, Some [("node_idx", intType, []); + ("num_edges", intType, [])], + false, [])) + +let initFun = + makeGlobalVar "init_blocking_graph" + (TFun (voidType, Some [("num_nodes", intType, [])], + false, [])) + +let fingerprintVar = + let vi = makeGlobalVar "stack_fingerprint" intType in + vi.vstorage <- Extern; + vi + +let startNodeAddrs = + let vi = makeGlobalVar "start_node_addrs" (TPtr (voidPtrType, [])) in + vi.vstorage <- Extern; + vi + +let startNodeStacks = + let vi = makeGlobalVar "start_node_stacks" (TPtr (intType, [])) in + vi.vstorage <- Extern; + vi + +let startNodeAddrsArray = + makeGlobalVar "start_node_addrs_array" (TArray (voidPtrType, None, [])) + +let startNodeStacksArray = + makeGlobalVar "start_node_stacks_array" (TArray (intType, None, [])) + +let insertInstr (newInstr: instr) (s: stmt) : unit = + match s.skind with + Instr instrs -> + let rec insert (instrs: instr list) : instr list = + match instrs with + [] -> E.s (bug "instr list does not end with call\n") + | [Call _] -> newInstr :: instrs + | i :: rest -> i :: (insert rest) + in + s.skind <- Instr (insert instrs) + | _ -> + E.s (bug "instr stmt expected\n") + +let instrumentBlockingPoints () = + List.iter + (fun bpt -> + if bpt.id > 1 then + let arg1 = integer bpt.id in + let arg2 = integer (List.length bpt.leadsto) in + let call = Call (None, Lval (var beforeFun), + [arg1; arg2], locUnknown) in + insertInstr call bpt.point; + addCall (getFunctionNode bpt.infun) + (getFunctionNode beforeFun.vname) None) + !blockingPoints + + +let startNodes : node list ref = ref [] + +let makeAndDumpBlockingGraphs () : unit = + if List.length !startNodes > 1 then + E.s (unimp "We can't handle more than one start node right now.\n"); + List.iter + (fun n -> + markYieldPoints n; + (*dumpFunctionCallGraph n;*) + makeBlockingGraph n; + dumpBlockingGraph (); + instrumentBlockingPoints ()) + !startNodes + + +let pragmas : (string, int) Hashtbl.t = Hashtbl.create 13 + +let gatherPragmas (f: file) : unit = + List.iter + (function + GPragma (Attr ("stacksize", [AStr s; AInt n]), _) -> + Hashtbl.add pragmas s n + | _ -> ()) + f.globals + + +let blockingNodes : node list ref = ref [] + +let markBlockingFunctions () : unit = + let rec markFunction (n: node) : unit = + if debug then + ignore (E.log "marking %s\n" n.name); + if n.origkind = NoBlock then begin + n.origkind <- BlockTrans; + List.iter markFunction n.preds; + end + in + List.iter (fun n -> List.iter markFunction n.preds) !blockingNodes + +let hasFunctionTypeAttribute (n: string) (t: typ) : bool = + let _, _, _, a = splitFunctionType t in + hasAttribute n a + +let markVar (vi: varinfo) : unit = + let node = getFunctionNode vi.vname in + if node.origkind = NoBlock then begin + if hasAttribute "yield" vi.vattr then begin + node.origkind <- BlockPoint; + blockingNodes := node :: !blockingNodes; + end else if hasFunctionTypeAttribute "noreturn" vi.vtype then begin + node.origkind <- EndPoint; + end else if hasAttribute "expand" vi.vattr then begin + node.expand <- true; + end + end; + begin + try + node.stacksize <- Hashtbl.find pragmas node.name + with Not_found -> begin + match filterAttributes "stacksize" vi.vattr with + (Attr (_, [AInt n])) :: _ when n > node.stacksize -> + node.stacksize <- n + | _ -> () + end + end + +let makeFunctionCallGraph (f: Cil.file) : unit = + Hashtbl.clear functionNodes; + (* Scan the file and construct the control-flow graph *) + List.iter + (function + GFun(fdec, _) -> + let curNode = getFunctionNode fdec.svar.vname in + if fdec.svar.vaddrof then begin + addCall (getFunctionPtrNode fdec.svar.vtype) + curNode None; + end; + if hasAttribute "start" fdec.svar.vattr then begin + startNodes := curNode :: !startNodes; + end; + markVar fdec.svar; + curNode.fds <- Some fdec; + let vis = new findCallsVisitor curNode in + ignore (visitCilBlock vis fdec.sbody) + + | GVarDecl(vi, _) when isFunctionType vi.vtype -> + (* TODO: what if we take the addr of an extern? *) + markVar vi + + | _ -> ()) + f.globals + +let makeStartNodeLinks () : unit = + addCall startNode (getFunctionNode "main") None; + List.iter (fun n -> addCall startNode n None) !startNodes + +let funType (ret_t: typ) (args: (string * typ) list) = + TFun(ret_t, + Some (List.map (fun (n,t) -> (n, t, [])) args), + false, []) + +class instrumentClass = object + inherit nopCilVisitor + + val mutable curNode : node ref = ref (getFunctionNode "main") + val mutable seenRet : bool ref = ref false + + val mutable funId : int ref = ref 0 + + method vfunc (fdec: fundec) : fundec visitAction = begin + (* Remember the current function. *) + curNode := getFunctionNode fdec.svar.vname; + seenRet := false; + funId := Random.bits (); + (* Add useful locals. *) + ignore (makeLocalVar fdec "savesp" voidPtrType); + ignore (makeLocalVar fdec "savechunk" voidPtrType); + ignore (makeLocalVar fdec "savebottom" voidPtrType); + (* Add macro for function entry when we're done. *) + let addEntryNode (fdec: fundec) : fundec = + if not !seenRet then E.s (bug "didn't find a return statement"); + let node = getFunctionNode fdec.svar.vname in + if fingerprintAll || node.origkind <> NoBlock then begin + let fingerprintSet = + Set (var fingerprintVar, BinOp (BXor, Lval (var fingerprintVar), + integer !funId, intType), + locUnknown) + in + fdec.sbody.bstmts <- mkStmtOneInstr fingerprintSet :: fdec.sbody.bstmts + end; + let nodeFun = emptyFunction ("NODE_CALL_"^(string_of_int node.nodeid)) in + let nodeCall = Call (None, Lval (var nodeFun.svar), [], locUnknown) in + nodeFun.svar.vtype <- funType voidType []; + nodeFun.svar.vstorage <- Static; + fdec.sbody.bstmts <- mkStmtOneInstr nodeCall :: fdec.sbody.bstmts; + fdec + in + ChangeDoChildrenPost (fdec, addEntryNode) + end + + method vstmt (s: stmt) : stmt visitAction = begin + begin + match s.skind with + Instr instrs -> begin + let instrumentNode (callNode: node) : unit = + (* Make calls to macros. *) + let suffix = "_" ^ (string_of_int !curNode.nodeid) ^ + "_" ^ (string_of_int callNode.nodeid) + in + let beforeFun = emptyFunction ("BEFORE_CALL" ^ suffix) in + let beforeCall = Call (None, Lval (var beforeFun.svar), + [], locUnknown) in + beforeFun.svar.vtype <- funType voidType []; + beforeFun.svar.vstorage <- Static; + let afterFun = emptyFunction ("AFTER_CALL" ^ suffix) in + let afterCall = Call (None, Lval (var afterFun.svar), + [], locUnknown) in + afterFun.svar.vtype <- funType voidType []; + afterFun.svar.vstorage <- Static; + (* Insert instrumentation around call site. *) + let rec addCalls (is: instr list) : instr list = + match is with + [call] -> [beforeCall; call; afterCall] + | cur :: rest -> cur :: addCalls rest + | [] -> E.s (bug "expected list of non-zero length") + in + s.skind <- Instr (addCalls instrs) + in + (* If there's a call site here, instrument it. *) + let len = List.length instrs in + if len > 0 then begin + match List.nth instrs (len - 1) with + Call (_, Lval (Var vi, NoOffset), _, _) -> + (* + if (try String.sub vi.vname 0 10 <> "NODE_CALL_" + with Invalid_argument _ -> true) then +*) + instrumentNode (getFunctionNode vi.vname) + | Call (_, e, _, _) -> (* Calling a function pointer *) + instrumentNode (getFunctionPtrNode (typeOf e)) + | _ -> () + end; + DoChildren + end + | Cil.Return _ -> begin + if !seenRet then E.s (bug "found multiple returns"); + seenRet := true; + if fingerprintAll || !curNode.origkind <> NoBlock then begin + let fingerprintSet = + Set (var fingerprintVar, BinOp (BXor, Lval (var fingerprintVar), + integer !funId, intType), + locUnknown) + in + s.skind <- Block (mkBlock [mkStmtOneInstr fingerprintSet; + mkStmt s.skind]); + end; + SkipChildren + end + | _ -> DoChildren + end + end +end + +let makeStartNodeTable (globs: global list) : global list = + if List.length !startNodes = 0 then + globs + else + let addrInitInfo = { init = None } in + let stackInitInfo = { init = None } in + let rec processNode (nodes: node list) (i: int) = + match nodes with + node :: rest -> + let curGlobs, addrInit, stackInit = processNode rest (i + 1) in + let fd = + match node.fds with + Some fd -> fd + | None -> E.s (bug "expected fundec") + in + let stack = + makeGlobalVar ("NODE_STACK_" ^ (string_of_int node.nodeid)) intType + in + GVarDecl (fd.svar, locUnknown) :: curGlobs, + ((Index (integer i, NoOffset), SingleInit (mkAddrOf (var fd.svar))) :: + addrInit), + ((Index (integer i, NoOffset), SingleInit (Lval (var stack))) :: + stackInit) + | [] -> (GVarDecl (startNodeAddrs, locUnknown) :: + GVarDecl (startNodeStacks, locUnknown) :: + GVar (startNodeAddrsArray, addrInitInfo, locUnknown) :: + GVar (startNodeStacksArray, stackInitInfo, locUnknown) :: + []), + [Index (integer i, NoOffset), SingleInit zero], + [Index (integer i, NoOffset), SingleInit zero] + in + let newGlobs, addrInit, stackInit = processNode !startNodes 0 in + addrInitInfo.init <- + Some (CompoundInit (TArray (voidPtrType, None, []), addrInit)); + stackInitInfo.init <- + Some (CompoundInit (TArray (intType, None, []), stackInit)); + let file = { fileName = "startnode.h"; globals = newGlobs; + globinit = None; globinitcalled = false; } in + let channel = open_out file.fileName in + dumpFile defaultCilPrinter channel file; + close_out channel; + GText ("#include \"" ^ file.fileName ^ "\"") :: globs + +let instrumentProgram (f: file) : unit = + (* Add function prototypes. *) + f.globals <- makeStartNodeTable f.globals; + f.globals <- GText ("#include \"stack.h\"") :: + GVarDecl (initFun, locUnknown) :: + GVarDecl (beforeFun, locUnknown) :: + GVarDecl (fingerprintVar, locUnknown) :: + f.globals; + (* Add instrumentation to call sites. *) + visitCilFile ((new instrumentClass) :> cilVisitor) f; + (* Force creation of this node. *) + ignore (getFunctionNode beforeFun.vname); + (* Add initialization call to main(). *) + let mainNode = getFunctionNode "main" in + match mainNode.fds with + Some fdec -> + let arg1 = integer (List.length !blockingPoints) in + let initInstr = Call (None, Lval (var initFun), [arg1], locUnknown) in + let addrsInstr = + Set (var startNodeAddrs, StartOf (var startNodeAddrsArray), + locUnknown) + in + let stacksInstr = + Set (var startNodeStacks, StartOf (var startNodeStacksArray), + locUnknown) + in + let newStmt = + if List.length !startNodes = 0 then + mkStmtOneInstr initInstr + else + mkStmt (Instr [addrsInstr; stacksInstr; initInstr]) + in + fdec.sbody.bstmts <- newStmt :: fdec.sbody.bstmts; + addCall mainNode (getFunctionNode initFun.vname) None + | None -> + E.s (bug "expected main fundec") + + + +let feature : featureDescr = + { fd_name = "FCG"; + fd_enabled = ref false; + fd_description = "computing and printing a static call graph"; + fd_extraopt = []; + fd_doit = + (function (f : file) -> + Random.init 0; (* Use the same seed so that results are predictable. *) + gatherPragmas f; + makeFunctionCallGraph f; + makeStartNodeLinks (); + markBlockingFunctions (); + (* makeAndDumpBlockingGraphs (); *) + instrumentProgram f; + dumpFunctionCallGraphToFile ()); + fd_post_check = true; + } diff --git a/cil/src/ext/blockinggraph.mli b/cil/src/ext/blockinggraph.mli new file mode 100644 index 0000000..72f9ba7 --- /dev/null +++ b/cil/src/ext/blockinggraph.mli @@ -0,0 +1,40 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* This module finds and analyzes yield points. *) + +val feature: Cil.featureDescr diff --git a/cil/src/ext/callgraph.ml b/cil/src/ext/callgraph.ml new file mode 100644 index 0000000..58472ac --- /dev/null +++ b/cil/src/ext/callgraph.ml @@ -0,0 +1,250 @@ +(* callgraph.ml *) +(* code for callgraph.mli *) + +(* see copyright notice at end of this file *) + +open Cil +open Trace +open Printf +module P = Pretty +module IH = Inthash +module H = Hashtbl +module E = Errormsg + +(* ------------------- interface ------------------- *) +(* a call node describes the local calling structure for a + * single function: which functions it calls, and which + * functions call it *) +type callnode = { + (* An id *) + cnid: int; + + (* the function this node describes *) + cnInfo: nodeinfo; + + (* set of functions this one calls, indexed by the node id *) + cnCallees: callnode IH.t; + + (* set of functions that call this one , indexed by the node id *) + cnCallers: callnode IH.t; +} + +and nodeinfo = + NIVar of varinfo * bool ref + (* Node corresponding to a function. If the boolean + * is true, then the function is defined, otherwise + * it is external *) + + | NIIndirect of string (* Indirect nodes have a string associated to them. + * These strings must be invalid function names *) + * varinfo list ref + (* A list of functions that this indirect node might + * denote *) + +let nodeName (n: nodeinfo) : string = + match n with + NIVar (v, _) -> v.vname + | NIIndirect (n, _) -> n + +(* a call graph is a hashtable, mapping a function name to + * the node which describes that function's call structure *) +type callgraph = + (string, callnode) Hashtbl.t + +(* given the name of a function, retrieve its callnode; this will create a + * node if one doesn't already exist. Will use the given nodeinfo only when + * creating nodes. *) +let nodeId = ref 0 +let getNodeByName (cg: callgraph) (ni: nodeinfo) : callnode = + let name = nodeName ni in + try + H.find cg name + with Not_found -> ( + (* make a new node *) + let ret:callnode = { + cnInfo = ni; + cnid = !nodeId; + cnCallees = IH.create 5; + cnCallers = IH.create 5; + } + in + incr nodeId; + (* add it to the table, then return it *) + H.add cg name ret; + ret + ) + +(* Get the node for a variable *) +let getNodeForVar (cg: callgraph) (v: varinfo) : callnode = + getNodeByName cg (NIVar (v, ref false)) + +let getNodeForIndirect (cg: callgraph) (e: exp) : callnode = + getNodeByName cg (NIIndirect ("", ref [])) + + +(* Find the name of an indirect node that a function whose address is taken + * belongs *) +let markFunctionAddrTaken (cg: callgraph) (f: varinfo) : unit = + (* + ignore (E.log "markFunctionAddrTaken %s\n" f.vname); + *) + let n = getNodeForIndirect cg (AddrOf (Var f, NoOffset)) in + match n.cnInfo with + NIIndirect (_, r) -> r := f :: !r + | _ -> assert false + + + +class cgComputer (graph: callgraph) = object(self) + inherit nopCilVisitor + + (* the current function we're in, so when we visit a call node + * we know who is the caller *) + val mutable curFunc: callnode option = None + + + (* begin visiting a function definition *) + method vfunc (f:fundec) : fundec visitAction = begin + (trace "callgraph" (P.dprintf "entering function %s\n" f.svar.vname)); + let node = getNodeForVar graph f.svar in + (match node.cnInfo with + NIVar (v, r) -> r := true + | _ -> assert false); + curFunc <- (Some node); + DoChildren + end + + (* visit an instruction; we're only interested in calls *) + method vinst (i:instr) : instr list visitAction = begin + (*(trace "callgraph" (P.dprintf "visiting instruction: %a\n" dn_instr i));*) + let caller : callnode = + match curFunc with + None -> assert false + | Some c -> c + in + let callerName: string = nodeName caller.cnInfo in + (match i with + Call(_,f,_,_) -> ( + let callee: callnode = + match f with + | Lval(Var(vi),NoOffset) -> + (trace "callgraph" (P.dprintf "I see a call by %s to %s\n" + callerName vi.vname)); + getNodeForVar graph vi + + | _ -> + (trace "callgraph" (P.dprintf "indirect call: %a\n" + dn_instr i)); + getNodeForIndirect graph f + in + + (* add one entry to each node's appropriate list *) + IH.replace caller.cnCallees callee.cnid callee; + IH.replace callee.cnCallers caller.cnid caller + ) + + | _ -> ()); (* ignore other kinds instructions *) + + DoChildren + end + + method vexpr (e: exp) = + (match e with + AddrOf (Var fv, NoOffset) when isFunctionType fv.vtype -> + markFunctionAddrTaken graph fv + | _ -> ()); + + DoChildren +end + +let computeGraph (f:file) : callgraph = begin + let graph = H.create 37 in + let obj:cgComputer = new cgComputer graph in + + (* visit the whole file, computing the graph *) + visitCilFileSameGlobals (obj :> cilVisitor) f; + + + (* return the computed graph *) + graph +end + +let printGraph (out:out_channel) (g:callgraph) : unit = begin + let printEntry _ (n:callnode) : unit = + let name = nodeName n.cnInfo in + (Printf.fprintf out " %s" name) + in + + let printCalls (node:callnode) : unit = + (fprintf out " calls:"); + (IH.iter printEntry node.cnCallees); + (fprintf out "\n is called by:"); + (IH.iter printEntry node.cnCallers); + (fprintf out "\n") + in + + H.iter (fun (name: string) (node: callnode) -> + match node.cnInfo with + NIVar (v, def) -> + (fprintf out "%s (%s):\n" + v.vname (if !def then "defined" else "external")); + printCalls node + + | NIIndirect (n, funcs) -> + fprintf out "Indirect %s:\n" n; + fprintf out " possible aliases: "; + List.iter (fun a -> fprintf out "%s " a.vname) !funcs; + fprintf out "\n" + + ) + + g + end + +let doCallGraph = ref false + +let feature : featureDescr = + { fd_name = "callgraph"; + fd_enabled = doCallGraph; + fd_description = "generation of a static call graph"; + fd_extraopt = []; + fd_doit = + (function (f: file) -> + let graph:callgraph = computeGraph f in + printGraph stdout graph); + fd_post_check = false; + } + + +(* + * + * Copyright (c) 2001-2002 by + * George C. Necula necula@cs.berkeley.edu + * Scott McPeak smcpeak@cs.berkeley.edu + * Wes Weimer weimer@cs.berkeley.edu + * Ben Liblit liblit@cs.berkeley.edu + * + * All rights reserved. Permission to use, copy, modify and distribute + * this software for research purposes only is hereby granted, + * provided that the following conditions are met: + * 1. XSRedistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * 3. The name of the authors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * DISCLAIMER: + * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) diff --git a/cil/src/ext/callgraph.mli b/cil/src/ext/callgraph.mli new file mode 100644 index 0000000..bc76018 --- /dev/null +++ b/cil/src/ext/callgraph.mli @@ -0,0 +1,123 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +(* callgraph.mli *) +(* compute a static call graph *) + +(* module maintainer: scott *) +(* see copyright notice at end of this file *) + + +(* ------------------ types ------------------- *) +(* a call node describes the local calling structure for a + * single function: which functions it calls, and which + * functions call it *) +type callnode = { + (* An id *) + cnid: int; + + (* the function this node describes *) + cnInfo: nodeinfo; + + (* set of functions this one calls, indexed by the node id *) + cnCallees: callnode Inthash.t; + + (* set of functions that call this one , indexed by the node id *) + cnCallers: callnode Inthash.t; +} + +and nodeinfo = + NIVar of Cil.varinfo * bool ref + (* Node corresponding to a function. If the boolean + * is true, then the function is defined, otherwise + * it is external *) + + | NIIndirect of string (* Indirect nodes have a string associated to them. + * These strings must be invalid function names *) + * Cil.varinfo list ref + (* A list of functions that this indirect node might + * denote *) + + +val nodeName: nodeinfo -> string + +(* a call graph is a hashtable, mapping a function name to + * the node which describes that function's call structure *) +type callgraph = + (string, callnode) Hashtbl.t + + +(* ----------------- functions ------------------- *) +(* given a CIL file, compute its static call graph *) +val computeGraph : Cil.file -> callgraph + +(* print the callgraph in a human-readable format to a channel *) +val printGraph : out_channel -> callgraph -> unit + + +val feature: Cil.featureDescr +(* + * + * Copyright (c) 2001-2002 by + * George C. Necula necula@cs.berkeley.edu + * Scott McPeak smcpeak@cs.berkeley.edu + * Wes Weimer weimer@cs.berkeley.edu + * Ben Liblit liblit@cs.berkeley.edu + * + * All rights reserved. Permission to use, copy, modify and distribute + * this software for research purposes only is hereby granted, + * provided that the following conditions are met: + * 1. Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * 3. The name of the authors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * DISCLAIMER: + * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) diff --git a/cil/src/ext/canonicalize.ml b/cil/src/ext/canonicalize.ml new file mode 100644 index 0000000..a75deea --- /dev/null +++ b/cil/src/ext/canonicalize.ml @@ -0,0 +1,292 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + + +(************************************************************************ + * canonicalize performs several transformations to correct differences + * between C and C++, so that the output is (hopefully) valid C++ code. + * This is incomplete -- certain fixes which are necessary + * for some programs are not yet implemented. + * + * #1) C allows global variables to have multiple declarations and multiple + * (equivalent) definitions. This transformation removes all but one + * declaration and all but one definition. + * + * #2) Any variables that use C++ keywords as identifiers are renamed. + * + * #3) __inline is #defined to inline, and __restrict is #defined to nothing. + * + * #4) C allows function pointers with no specified arguments to be used on + * any argument list. To make C++ accept this code, we insert a cast + * from the function pointer to a type that matches the arguments. Of + * course, this does nothing to guarantee that the pointer actually has + * that type. + * + * #5) Makes casts from int to enum types explicit. (CIL changes enum + * constants to int constants, but doesn't use a cast.) + * + ************************************************************************) + +open Cil +module E = Errormsg +module H = Hashtbl + +(* For transformation #1. Stores all variable definitions in the file. *) +let varDefinitions: (varinfo, global) H.t = H.create 111 + + +class canonicalizeVisitor = object(self) + inherit nopCilVisitor + val mutable currentFunction: fundec = Cil.dummyFunDec; + + (* A hashtable to prevent duplicate declarations. *) + val alreadyDeclared: (varinfo, unit) H.t = H.create 111 + val alreadyDefined: (varinfo, unit) H.t = H.create 111 + + (* move variable declarations around *) + method vglob g = match g with + GVar(v, ({init = Some _} as inito), l) -> + (* A definition. May have been moved to an earlier position. *) + if H.mem alreadyDefined v then begin + ignore (E.warn "Duplicate definition of %s at %a.\n" + v.vname d_loc !currentLoc); + ChangeTo [] (* delete from here. *) + end else begin + H.add alreadyDefined v (); + if H.mem alreadyDeclared v then begin + (* Change the earlier declaration to Extern *) + let oldS = v.vstorage in + ignore (E.log "changing storage of %s from %a\n" + v.vname d_storage oldS); + v.vstorage <- Extern; + let newv = {v with vstorage = oldS} in + ChangeDoChildrenPost([GVar(newv, inito, l)], (fun g -> g) ) + end else + DoChildren + end + | GVar(v, {init=None}, l) + | GVarDecl(v, l) when not (isFunctionType v.vtype) -> begin + (* A declaration. May have been moved to an earlier position. *) + if H.mem alreadyDefined v || H.mem alreadyDeclared v then + ChangeTo [] (* delete from here. *) + else begin + H.add alreadyDeclared v (); + DoChildren + end + end + | GFun(f, l) -> + currentFunction <- f; + DoChildren + | _ -> + DoChildren + +(* #2. rename any identifiers whose names are C++ keywords *) + method vvdec v = + match v.vname with + | "bool" + | "catch" + | "cdecl" + | "class" + | "const_cast" + | "delete" + | "dynamic_cast" + | "explicit" + | "export" + | "false" + | "friend" + | "mutable" + | "namespace" + | "new" + | "operator" + | "pascal" + | "private" + | "protected" + | "public" + | "register" + | "reinterpret_cast" + | "static_cast" + | "template" + | "this" + | "throw" + | "true" + | "try" + | "typeid" + | "typename" + | "using" + | "virtual" + | "wchar_t"-> + v.vname <- v.vname ^ "__cil2cpp"; + DoChildren + | _ -> DoChildren + + method vinst i = +(* #5. If an assignment or function call uses expressions as enum values, + add an explicit cast. *) + match i with + Set (dest, exp, l) -> begin + let typeOfDest = typeOfLval dest in + match unrollType typeOfDest with + TEnum _ -> (* add an explicit cast *) + let newI = Set(dest, mkCast exp typeOfDest, l) in + ChangeTo [newI] + | _ -> SkipChildren + end + | Call (dest, f, args, l) -> begin + let rt, formals, isva, attrs = splitFunctionType (typeOf f) in + if isva then + SkipChildren (* ignore vararg functions *) + else + match formals with + Some formals' -> begin + let newArgs = try + (*Iterate over the arguments, looking for formals that + expect enum types, and insert casts where necessary. *) + List.map2 + (fun (actual: exp) (formalName, formalType, _) -> + match unrollType formalType with + TEnum _ -> mkCast actual formalType + | _ -> actual) + args + formals' + with Invalid_argument _ -> + E.s (error "Number of arguments to %a doesn't match type.\n" + d_exp f) + in + let newI = Call(dest, f, newArgs, l) in + ChangeTo [newI] + end + | None -> begin + (* #4. No arguments were specified for this type. To fix this, infer the + type from the arguments that are used n this instruction, and insert + a cast to that type.*) + match f with + Lval(Mem(fp), off) -> + let counter: int ref = ref 0 in + let newFormals = List.map + (fun (actual:exp) -> + incr counter; + let formalName = "a" ^ (string_of_int !counter) in + (formalName, typeOf actual, []))(* (name,type,attrs) *) + args in + let newFuncPtrType = + TPtr((TFun (rt, Some newFormals, false, attrs)), []) in + let newFuncPtr = Lval(Mem(mkCast fp newFuncPtrType), off) in + ChangeTo [Call(dest, newFuncPtr, args, l)] + | _ -> + ignore (warn "cppcanon: %a has no specified arguments, but it's not a function pointer." d_exp f); + SkipChildren + end + end + | _ -> SkipChildren + + method vinit i = +(* #5. If an initializer uses expressions as enum values, + add an explicit cast. *) + match i with + SingleInit e -> DoChildren (* we don't handle simple initializers here, + because we don't know what type is expected. + This should be done in vglob if needed. *) + | CompoundInit(t, initList) -> + let changed: bool ref = ref false in + let initList' = List.map + (* iterate over the list, adding casts for any expression that + is expected to be an enum type. *) + (function + (Field(fi, off), SingleInit e) -> begin + match unrollType fi.ftype with + TEnum _ -> (* add an explicit cast *) + let newE = mkCast e fi.ftype in + changed := true; + (Field(fi, off), SingleInit newE) + | _ -> (* not enum, no cast needed *) + (Field(fi, off), SingleInit e) + end + | other -> + (* This is a more complicated initializer, and I don't think + it can have type enum. It's children might, though. *) + other) + initList in + if !changed then begin + (* There may be other casts needed in other parts of the + initialization, so do the children too. *) + ChangeDoChildrenPost(CompoundInit(t, initList'), (fun x -> x)) + end else + DoChildren + + +(* #5. If a function returns an enum type, add an explicit cast to the + return type. *) + method vstmt stmt = + (match stmt.skind with + Return (Some exp, l) -> begin + let typeOfDest, _, _, _ = + splitFunctionType currentFunction.svar.vtype in + match unrollType typeOfDest with + TEnum _ -> + stmt.skind <- Return (Some (mkCast exp typeOfDest), l) + | _ -> () + end + | _ -> ()); + DoChildren +end (* class canonicalizeVisitor *) + + + +(* Entry point for this extension *) +let canonicalize (f:file) = + visitCilFile (new canonicalizeVisitor) f; + + (* #3. Finally, add some #defines to change C keywords to their C++ + equivalents: *) + f.globals <- + GText( "#ifdef __cplusplus\n" + ^" #define __restrict\n" (* "restrict" doesn't work *) + ^" #define __inline inline\n" + ^"#endif") + ::f.globals + + + +let feature : featureDescr = + { fd_name = "canonicalize"; + fd_enabled = ref false; + fd_description = "fixing some C-isms so that the result is C++ compliant."; + fd_extraopt = []; + fd_doit = canonicalize; + fd_post_check = true; + } diff --git a/cil/src/ext/canonicalize.mli b/cil/src/ext/canonicalize.mli new file mode 100644 index 0000000..37bc0d8 --- /dev/null +++ b/cil/src/ext/canonicalize.mli @@ -0,0 +1,48 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(************************************************************************ + * canonicalize performs several transformations to correct differences + * between C and C++, so that the output is (hopefully) valid C++ code. + * This is incomplete -- certain fixes which are necessary + * for some programs are not yet implemented. + * + * See canonicalize.ml for a list of changes. + * + ************************************************************************) + +val feature: Cil.featureDescr diff --git a/cil/src/ext/cfg.ml b/cil/src/ext/cfg.ml new file mode 100644 index 0000000..8b19c79 --- /dev/null +++ b/cil/src/ext/cfg.ml @@ -0,0 +1,289 @@ +(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) + +(* + * + * Copyright (c) 2001-2003, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Simon Goldsmith + * S.P Rahul, Aman Bhargava + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* Authors: Aman Bhargava, S. P. Rahul *) +(* sfg: this stuff was stolen from optim.ml - the code to print the cfg as + a dot graph is mine *) + +open Pretty +open Cil +module E=Errormsg + +(* entry points: cfgFun, printCfgChannel, printCfgFilename *) + +(* known issues: + * -sucessors of if somehow end up with two edges each + *) + +(*------------------------------------------------------------*) +(* Notes regarding CFG computation: + 1) Initially only succs and preds are computed. sid's are filled in + later, in whatever order is suitable (e.g. for forward problems, reverse + depth-first postorder). + 2) If a stmt (return, break or continue) has no successors, then + function return must follow. + No predecessors means it is the start of the function + 3) We use the fact that initially all the succs and preds are assigned [] +*) + +(* Fill in the CFG info for the stmts in a block + next = succ of the last stmt in this block + break = succ of any Break in this block + cont = succ of any Continue in this block + None means the succ is the function return. It does not mean the break/cont + is invalid. We assume the validity has already been checked. +*) +(* At the end of CFG computation, + - numNodes = total number of CFG nodes + - length(nodeList) = numNodes +*) + +let numNodes = ref 0 (* number of nodes in the CFG *) +let nodeList : stmt list ref = ref [] (* All the nodes in a flat list *) (* ab: Added to change dfs from quadratic to linear *) +let start_id = ref 0 (* for unique ids across many functions *) + +(* entry point *) + +(** Compute a control flow graph for fd. Stmts in fd have preds and succs + filled in *) +let rec cfgFun (fd : fundec): int = + begin + numNodes := !start_id; + nodeList := []; + + cfgBlock fd.sbody None None None; + !numNodes - !start_id + end + + +and cfgStmts (ss: stmt list) + (next:stmt option) (break:stmt option) (cont:stmt option) = + match ss with + [] -> (); + | [s] -> cfgStmt s next break cont + | hd::tl -> + cfgStmt hd (Some (List.hd tl)) break cont; + cfgStmts tl next break cont + +and cfgBlock (blk: block) + (next:stmt option) (break:stmt option) (cont:stmt option) = + cfgStmts blk.bstmts next break cont + +(* Fill in the CFG info for a stmt + Meaning of next, break, cont should be clear from earlier comment +*) +and cfgStmt (s: stmt) (next:stmt option) (break:stmt option) (cont:stmt option) = + incr numNodes; + s.sid <- !numNodes; + nodeList := s :: !nodeList; (* Future traversals can be made in linear time. e.g. *) + if s.succs <> [] then + E.s (bug "CFG must be cleared before being computed!"); + let addSucc (n: stmt) = + if not (List.memq n s.succs) then + s.succs <- n::s.succs; + if not (List.memq s n.preds) then + n.preds <- s::n.preds + in + let addOptionSucc (n: stmt option) = + match n with + None -> () + | Some n' -> addSucc n' + in + let addBlockSucc (b: block) = + match b.bstmts with + [] -> addOptionSucc next + | hd::_ -> addSucc hd + in + match s.skind with + Instr _ -> addOptionSucc next + | Return _ -> () + | Goto (p,_) -> addSucc !p + | Break _ -> addOptionSucc break + | Continue _ -> addOptionSucc cont + | If (_, blk1, blk2, _) -> + (* The succs of If is [true branch;false branch] *) + addBlockSucc blk2; + addBlockSucc blk1; + cfgBlock blk1 next break cont; + cfgBlock blk2 next break cont + | Block b -> + addBlockSucc b; + cfgBlock b next break cont + | Switch(_,blk,l,_) -> + List.iter addSucc (List.rev l); (* Add successors in order *) + (* sfg: if there's no default, need to connect s->next *) + if not (List.exists + (fun stmt -> List.exists + (function Default _ -> true | _ -> false) + stmt.labels) + l) + then + addOptionSucc next; + cfgBlock blk next next cont +(* + | Loop(blk,_,_,_) -> +*) + | While(_,blk,_) + | DoWhile(_,blk,_) + | For(_,_,_,blk,_) -> + addBlockSucc blk; + cfgBlock blk (Some s) next (Some s) + (* Since all loops have terminating condition true, we don't put + any direct successor to stmt following the loop *) + | TryExcept _ | TryFinally _ -> + E.s (E.unimp "try/except/finally") + +(*------------------------------------------------------------*) + +(**************************************************************) +(* do something for all stmts in a fundec *) + +let rec forallStmts (todo) (fd : fundec) = + begin + fasBlock todo fd.sbody; + end + +and fasBlock (todo) (b : block) = + List.iter (fasStmt todo) b.bstmts + +and fasStmt (todo) (s : stmt) = + begin + ignore(todo s); + match s.skind with + | Block b -> fasBlock todo b + | If (_, tb, fb, _) -> (fasBlock todo tb; fasBlock todo fb) + | Switch (_, b, _, _) -> fasBlock todo b +(* + | Loop (b, _, _, _) -> fasBlock todo b +*) + | While (_, b, _) -> fasBlock todo b + | DoWhile (_, b, _) -> fasBlock todo b + | For (_, _, _, b, _) -> fasBlock todo b + | (Return _ | Break _ | Continue _ | Goto _ | Instr _) -> () + | TryExcept _ | TryFinally _ -> E.s (E.unimp "try/except/finally") + end +;; + +(**************************************************************) +(* printing the control flow graph - you have to compute it first *) + +let d_cfgnodename () (s : stmt) = + dprintf "%d" s.sid + +let d_cfgnodelabel () (s : stmt) = + let label = + begin + match s.skind with + | If (e, _, _, _) -> "if" (*sprint ~width:999 (dprintf "if %a" d_exp e)*) +(* + | Loop _ -> "loop" +*) + | While _ -> "while" + | DoWhile _ -> "dowhile" + | For _ -> "for" + | Break _ -> "break" + | Continue _ -> "continue" + | Goto _ -> "goto" + | Instr _ -> "instr" + | Switch _ -> "switch" + | Block _ -> "block" + | Return _ -> "return" + | TryExcept _ -> "try-except" + | TryFinally _ -> "try-finally" + end in + dprintf "%d: %s" s.sid label + +let d_cfgedge (src) () (dest) = + dprintf "%a -> %a" + d_cfgnodename src + d_cfgnodename dest + +let d_cfgnode () (s : stmt) = + dprintf "%a [label=\"%a\"]\n\t%a" + d_cfgnodename s + d_cfgnodelabel s + (d_list "\n\t" (d_cfgedge s)) s.succs + +(**********************************************************************) +(* entry points *) + +(** print control flow graph (in dot form) for fundec to channel *) +let printCfgChannel (chan : out_channel) (fd : fundec) = + let pnode (s:stmt) = fprintf chan "%a\n" d_cfgnode s in + begin + ignore (fprintf chan "digraph CFG_%s {\n" fd.svar.vname); + forallStmts pnode fd; + ignore(fprintf chan "}\n"); + end + +(** Print control flow graph (in dot form) for fundec to file *) +let printCfgFilename (filename : string) (fd : fundec) = + let chan = open_out filename in + begin + printCfgChannel chan fd; + close_out chan; + end + + +;; + +(**********************************************************************) + +let clearCFGinfo (fd : fundec) = + let clear s = + s.sid <- -1; + s.succs <- []; + s.preds <- []; + in + forallStmts clear fd + +let clearFileCFG (f : file) = + iterGlobals f (fun g -> + match g with GFun(fd,_) -> + clearCFGinfo fd + | _ -> ()) + +let computeFileCFG (f : file) = + iterGlobals f (fun g -> + match g with GFun(fd,_) -> + numNodes := cfgFun fd; + start_id := !start_id + !numNodes + | _ -> ()) diff --git a/cil/src/ext/cfg.mli b/cil/src/ext/cfg.mli new file mode 100644 index 0000000..19c5166 --- /dev/null +++ b/cil/src/ext/cfg.mli @@ -0,0 +1,36 @@ +(** Code to compute the control-flow graph of a function or file. + This will fill in the [preds] and [succs] fields of {!Cil.stmt} + + This is required for several other extensions, such as {!Dataflow}. +*) + +open Cil + + +(** Compute the CFG for an entire file, by calling cfgFun on each function. *) +val computeFileCFG: Cil.file -> unit + +(** clear the sid, succs, and preds fields of each statement. *) +val clearFileCFG: Cil.file -> unit + +(** Compute a control flow graph for fd. Stmts in fd have preds and succs + filled in *) +val cfgFun : fundec -> int + +(** clear the sid, succs, and preds fields of each statment in a function *) +val clearCFGinfo: Cil.fundec -> unit + +(** print control flow graph (in dot form) for fundec to channel *) +val printCfgChannel : out_channel -> fundec -> unit + +(** Print control flow graph (in dot form) for fundec to file *) +val printCfgFilename : string -> fundec -> unit + +(** Next statement id that will be assigned. *) +val start_id: int ref + +(** All of the nodes in a file. *) +val nodeList : stmt list ref + +(** number of nodes in the CFG *) +val numNodes : int ref diff --git a/cil/src/ext/ciltools.ml b/cil/src/ext/ciltools.ml new file mode 100755 index 0000000..78f1aaf --- /dev/null +++ b/cil/src/ext/ciltools.ml @@ -0,0 +1,228 @@ +open Cil + +(* Contributed by Nathan Cooprider *) + +let isOne e = + isInteger e = Some Int64.one + + +(* written by Zach *) +let is_volatile_tp tp = + List.exists (function (Attr("volatile",_)) -> true + | _ -> false) (typeAttrs tp) + +(* written by Zach *) +let is_volatile_vi vi = + let vi_vol = + List.exists (function (Attr("volatile",_)) -> true + | _ -> false) vi.vattr in + let typ_vol = is_volatile_tp vi.vtype in + vi_vol || typ_vol + +(***************************************************************************** + * A collection of useful functions that were not already in CIL as far as I + * could tell. However, I have been surprised before . . . + ****************************************************************************) + +type sign = Signed | Unsigned + +exception Not_an_integer + +(***************************************************************************** + * A bunch of functions for accessing integers. Originally written for + * somebody who didn't know CIL and just wanted to mess with it at the + * OCaml level. + ****************************************************************************) + +let unbox_int_type (ye : typ) : (int * sign) = + let tp = unrollType ye in + let s = + match tp with + TInt (i, _) -> + if (isSigned i) then + Signed + else + Unsigned + | _ -> raise Not_an_integer + in + (bitsSizeOf tp), s + +(* depricated. Use isInteger directly instead *) +let unbox_int_exp (e : exp) : int64 = + match isInteger e with + None -> raise Not_an_integer + | Some (x) -> x + +let box_int_to_exp (n : int64) (ye : typ) : exp = + let tp = unrollType ye in + match tp with + TInt (i, _) -> + kinteger64 i n + | _ -> raise Not_an_integer + +let cil_to_ocaml_int (e : exp) : (int64 * int * sign) = + let v, s = unbox_int_type (typeOf e) in + unbox_int_exp (e), v, s + +exception Weird_bitwidth + +(* (int64 * int * sign) : exp *) +let ocaml_int_to_cil v n s = + let char_size = bitsSizeOf charType in + let int_size = bitsSizeOf intType in + let short_size = bitsSizeOf (TInt(IShort,[]))in + let long_size = bitsSizeOf longType in + let longlong_size = bitsSizeOf (TInt(ILongLong,[])) in + let i = + match s with + Signed -> + if (n = char_size) then + ISChar + else if (n = int_size) then + IInt + else if (n = short_size) then + IShort + else if (n = long_size) then + ILong + else if (n = longlong_size) then + ILongLong + else + raise Weird_bitwidth + | Unsigned -> + if (n = char_size) then + IUChar + else if (n = int_size) then + IUInt + else if (n = short_size) then + IUShort + else if (n = long_size) then + IULong + else if (n = longlong_size) then + IULongLong + else + raise Weird_bitwidth + in + kinteger64 i v + +(***************************************************************************** + * a couple of type functions that I thought would be useful: + ****************************************************************************) + +let rec isCompositeType tp = + match tp with + TComp _ -> true + | TPtr(x, _) -> isCompositeType x + | TArray(x,_,_) -> isCompositeType x + | TFun(x,_,_,_) -> isCompositeType x + | TNamed (x,_) -> isCompositeType x.ttype + | _ -> false + +(** START OF deepHasAttribute ************************************************) +let visited = ref [] +class attribute_checker target rflag = object (self) + inherit nopCilVisitor + method vtype t = + match t with + TComp(cinfo, a) -> + if(not (List.exists (fun x -> cinfo.cname = x) !visited )) then begin + visited := cinfo.cname :: !visited; + List.iter + (fun f -> + if (hasAttribute target f.fattr) then + rflag := true + else + ignore(visitCilType (new attribute_checker target rflag) + f.ftype)) cinfo.cfields; + end; + DoChildren + | TNamed(t1, a) -> + if(not (List.exists (fun x -> t1.tname = x) !visited )) then begin + visited := t1.tname :: !visited; + ignore(visitCilType (new attribute_checker target rflag) t1.ttype); + end; + DoChildren + | _ -> + DoChildren + method vattr (Attr(name,params)) = + if (name = target) then rflag := true; + DoChildren +end + +let deepHasAttribute s t = + let found = ref false in + visited := []; + ignore(visitCilType (new attribute_checker s found) t); + !found +(** END OF deepHasAttribute **************************************************) + +(** Stuff from ptranal, slightly modified ************************************) + +(***************************************************************************** + * A transformation to make every instruction be in its own statement. + ****************************************************************************) + +class callBBVisitor = object + inherit nopCilVisitor + + method vstmt s = + match s.skind with + Instr(il) -> begin + if (List.length il > 1) then + let list_of_stmts = List.map (fun one_inst -> + mkStmtOneInstr one_inst) il in + let block = mkBlock list_of_stmts in + s.skind <- Block block; + ChangeTo(s) + else + SkipChildren + end + | _ -> DoChildren + + method vvdec _ = SkipChildren + method vexpr _ = SkipChildren + method vlval _ = SkipChildren + method vtype _ = SkipChildren +end + +let one_instruction_per_statement f = + let thisVisitor = new callBBVisitor in + visitCilFileSameGlobals thisVisitor f + +(***************************************************************************** + * A transformation that gives each variable a unique identifier. + ****************************************************************************) + +class vidVisitor = object + inherit nopCilVisitor + val count = ref 0 + + method vvdec vi = + vi.vid <- !count ; + incr count ; SkipChildren +end + +let globally_unique_vids f = + let thisVisitor = new vidVisitor in + visitCilFileSameGlobals thisVisitor f + +(** End of stuff from ptranal ************************************************) + +class sidVisitor = object + inherit nopCilVisitor + val count = ref 0 + + method vstmt s = + s.sid <- !count ; + incr count ; + DoChildren +end + +let globally_unique_sids f = + let thisVisitor = new sidVisitor in + visitCilFileSameGlobals thisVisitor f + +(** Comparing expressions without a Out_of_memory error **********************) + +let compare_exp x y = + compare x y + diff --git a/cil/src/ext/dataflow.ml b/cil/src/ext/dataflow.ml new file mode 100755 index 0000000..7f28f84 --- /dev/null +++ b/cil/src/ext/dataflow.ml @@ -0,0 +1,466 @@ +(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) + +module IH = Inthash +module E = Errormsg + +open Cil +open Pretty + +(** A framework for data flow analysis for CIL code. Before using + this framework, you must initialize the Control-flow Graph for your + program, e.g using {!Cfg.computeFileCFG} *) + +type 't action = + Default (** The default action *) + | Done of 't (** Do not do the default action. Use this result *) + | Post of ('t -> 't) (** The default action, followed by the given + * transformer *) + +type 't stmtaction = + SDefault (** The default action *) + | SDone (** Do not visit this statement or its successors *) + | SUse of 't (** Visit the instructions and successors of this statement + as usual, but use the specified state instead of the + one that was passed to doStmt *) + +(* For if statements *) +type 't guardaction = + GDefault (** The default state *) + | GUse of 't (** Use this data for the branch *) + | GUnreachable (** The branch will never be taken. *) + + +(****************************************************************** + ********** + ********** FORWARDS + ********** + ********************************************************************) + +module type ForwardsTransfer = sig + val name: string (** For debugging purposes, the name of the analysis *) + + val debug: bool ref (** Whether to turn on debugging *) + + type t (** The type of the data we compute for each block start. May be + * imperative. *) + + val copy: t -> t + (** Make a deep copy of the data *) + + + val stmtStartData: t Inthash.t + (** For each statement id, the data at the start. Not found in the hash + * table means nothing is known about the state at this point. At the end + * of the analysis this means that the block is not reachable. *) + + val pretty: unit -> t -> Pretty.doc + (** Pretty-print the state *) + + val computeFirstPredecessor: Cil.stmt -> t -> t + (** Give the first value for a predecessors, compute the value to be set + * for the block *) + + val combinePredecessors: Cil.stmt -> old:t -> t -> t option + (** Take some old data for the start of a statement, and some new data for + * the same point. Return None if the combination is identical to the old + * data. Otherwise, compute the combination, and return it. *) + + val doInstr: Cil.instr -> t -> t action + (** The (forwards) transfer function for an instruction. The + * {!Cil.currentLoc} is set before calling this. The default action is to + * continue with the state unchanged. *) + + val doStmt: Cil.stmt -> t -> t stmtaction + (** The (forwards) transfer function for a statement. The {!Cil.currentLoc} + * is set before calling this. The default action is to do the instructions + * in this statement, if applicable, and continue with the successors. *) + + val doGuard: Cil.exp -> t -> t guardaction + (** Generate the successor to an If statement assuming the given expression + * is nonzero. Analyses that don't need guard information can return + * GDefault; this is equivalent to returning GUse of the input. + * A return value of GUnreachable indicates that this half of the branch + * will not be taken and should not be explored. This will be called + * twice per If, once for "then" and once for "else". + *) + + val filterStmt: Cil.stmt -> bool + (** Whether to put this statement in the worklist. This is called when a + * block would normally be put in the worklist. *) + +end + + +module ForwardsDataFlow = + functor (T : ForwardsTransfer) -> + struct + + (** Keep a worklist of statements to process. It is best to keep a queue, + * because this way it is more likely that we are going to process all + * predecessors of a statement before the statement itself. *) + let worklist: Cil.stmt Queue.t = Queue.create () + + (** We call this function when we have encountered a statement, with some + * state. *) + let reachedStatement (s: stmt) (d: T.t) : unit = + (** see if we know about it already *) + E.pushContext (fun _ -> dprintf "Reached statement %d with %a" + s.sid T.pretty d); + let newdata: T.t option = + try + let old = IH.find T.stmtStartData s.sid in + match T.combinePredecessors s ~old:old d with + None -> (* We are done here *) + if !T.debug then + ignore (E.log "FF(%s): reached stmt %d with %a\n implies the old state %a\n" + T.name s.sid T.pretty d T.pretty old); + None + | Some d' -> begin + (* We have changed the data *) + if !T.debug then + ignore (E.log "FF(%s): weaken data for block %d: %a\n" + T.name s.sid T.pretty d'); + Some d' + end + with Not_found -> (* was bottom before *) + let d' = T.computeFirstPredecessor s d in + if !T.debug then + ignore (E.log "FF(%s): set data for block %d: %a\n" + T.name s.sid T.pretty d'); + Some d' + in + E.popContext (); + match newdata with + None -> () + | Some d' -> + IH.replace T.stmtStartData s.sid d'; + if T.filterStmt s && + not (Queue.fold (fun exists s' -> exists || s'.sid = s.sid) + false + worklist) then + Queue.add s worklist + + + (** Get the two successors of an If statement *) + let ifSuccs (s:stmt) : stmt * stmt = + let fstStmt blk = match blk.bstmts with + [] -> Cil.dummyStmt + | fst::_ -> fst + in + match s.skind with + If(e, b1, b2, _) -> + let thenSucc = fstStmt b1 in + let elseSucc = fstStmt b2 in + let oneFallthrough () = + let fallthrough = + List.filter + (fun s' -> thenSucc != s' && elseSucc != s') + s.succs + in + match fallthrough with + [] -> E.s (bug "Bad CFG: missing fallthrough for If.") + | [s'] -> s' + | _ -> E.s (bug "Bad CFG: multiple fallthrough for If.") + in + (* If thenSucc or elseSucc is Cil.dummyStmt, it's an empty block. + So the successor is the statement after the if *) + let stmtOrFallthrough s' = + if s' == Cil.dummyStmt then + oneFallthrough () + else + s' + in + (stmtOrFallthrough thenSucc, + stmtOrFallthrough elseSucc) + + | _-> E.s (bug "ifSuccs on a non-If Statement.") + + (** Process a statement *) + let processStmt (s: stmt) : unit = + currentLoc := get_stmtLoc s.skind; + if !T.debug then + ignore (E.log "FF(%s).stmt %d at %t\n" T.name s.sid d_thisloc); + + (* It must be the case that the block has some data *) + let init: T.t = + try T.copy (IH.find T.stmtStartData s.sid) + with Not_found -> + E.s (E.bug "FF(%s): processing block without data" T.name) + in + + (** See what the custom says *) + match T.doStmt s init with + SDone -> () + | (SDefault | SUse _) as act -> begin + let curr = match act with + SDefault -> init + | SUse d -> d + | SDone -> E.s (bug "SDone") + in + (* Do the instructions in order *) + let handleInstruction (s: T.t) (i: instr) : T.t = + currentLoc := get_instrLoc i; + + (* Now handle the instruction itself *) + let s' = + let action = T.doInstr i s in + match action with + | Done s' -> s' + | Default -> s (* do nothing *) + | Post f -> f s + in + s' + in + + let after: T.t = + match s.skind with + Instr il -> + (* Handle instructions starting with the first one *) + List.fold_left handleInstruction curr il + + | Goto _ | Break _ | Continue _ | If _ + | TryExcept _ | TryFinally _ + | Switch _ | (*Loop _*) While _ | DoWhile _ | For _ + | Return _ | Block _ -> curr + in + currentLoc := get_stmtLoc s.skind; + + (* Handle If guards *) + let succsToReach = match s.skind with + If (e, _, _, _) -> begin + let not_e = UnOp(LNot, e, intType) in + let thenGuard = T.doGuard e after in + let elseGuard = T.doGuard not_e after in + if thenGuard = GDefault && elseGuard = GDefault then + (* this is the common case *) + s.succs + else begin + let doBranch succ guard = + match guard with + GDefault -> reachedStatement succ after + | GUse d -> reachedStatement succ d + | GUnreachable -> + if !T.debug then + ignore (E.log "FF(%s): Not exploring branch to %d\n" + T.name succ.sid); + + () + in + let thenSucc, elseSucc = ifSuccs s in + doBranch thenSucc thenGuard; + doBranch elseSucc elseGuard; + [] + end + end + | _ -> s.succs + in + (* Reach the successors *) + List.iter (fun s' -> reachedStatement s' after) succsToReach; + + end + + + + + (** Compute the data flow. Must have the CFG initialized *) + let compute (sources: stmt list) = + Queue.clear worklist; + List.iter (fun s -> Queue.add s worklist) sources; + + (** All initial stmts must have non-bottom data *) + List.iter (fun s -> + if not (IH.mem T.stmtStartData s.sid) then + E.s (E.error "FF(%s): initial stmt %d does not have data" + T.name s.sid)) + sources; + if !T.debug then + ignore (E.log "\nFF(%s): processing\n" + T.name); + let rec fixedpoint () = + if !T.debug && not (Queue.is_empty worklist) then + ignore (E.log "FF(%s): worklist= %a\n" + T.name + (docList (fun s -> num s.sid)) + (List.rev + (Queue.fold (fun acc s -> s :: acc) [] worklist))); + try + let s = Queue.take worklist in + processStmt s; + fixedpoint (); + with Queue.Empty -> + if !T.debug then + ignore (E.log "FF(%s): done\n\n" T.name) + in + fixedpoint () + + end + + + +(****************************************************************** + ********** + ********** BACKWARDS + ********** + ********************************************************************) +module type BackwardsTransfer = sig + val name: string (* For debugging purposes, the name of the analysis *) + + val debug: bool ref (** Whether to turn on debugging *) + + type t (** The type of the data we compute for each block start. In many + * presentations of backwards data flow analysis we maintain the + * data at the block end. This is not easy to do with JVML because + * a block has many exceptional ends. So we maintain the data for + * the statement start. *) + + val pretty: unit -> t -> Pretty.doc (** Pretty-print the state *) + + val stmtStartData: t Inthash.t + (** For each block id, the data at the start. This data structure must be + * initialized with the initial data for each block *) + + val combineStmtStartData: Cil.stmt -> old:t -> t -> t option + (** When the analysis reaches the start of a block, combine the old data + * with the one we have just computed. Return None if the combination is + * the same as the old data, otherwise return the combination. In the + * latter case, the predecessors of the statement are put on the working + * list. *) + + + val combineSuccessors: t -> t -> t + (** Take the data from two successors and combine it *) + + + val doStmt: Cil.stmt -> t action + (** The (backwards) transfer function for a branch. The {!Cil.currentLoc} is + * set before calling this. If it returns None, then we have some default + * handling. Otherwise, the returned data is the data before the branch + * (not considering the exception handlers) *) + + val doInstr: Cil.instr -> t -> t action + (** The (backwards) transfer function for an instruction. The + * {!Cil.currentLoc} is set before calling this. If it returns None, then we + * have some default handling. Otherwise, the returned data is the data + * before the branch (not considering the exception handlers) *) + + val filterStmt: Cil.stmt -> Cil.stmt -> bool + (** Whether to put this predecessor block in the worklist. We give the + * predecessor and the block whose predecessor we are (and whose data has + * changed) *) + +end + +module BackwardsDataFlow = + functor (T : BackwardsTransfer) -> + struct + + let getStmtStartData (s: stmt) : T.t = + try IH.find T.stmtStartData s.sid + with Not_found -> + E.s (E.bug "BF(%s): stmtStartData is not initialized for %d" + T.name s.sid) + + (** Process a statement and return true if the set of live return + * addresses on its entry has changed. *) + let processStmt (s: stmt) : bool = + if !T.debug then + ignore (E.log "FF(%s).stmt %d\n" T.name s.sid); + + + (* Find the state before the branch *) + currentLoc := get_stmtLoc s.skind; + let d: T.t = + match T.doStmt s with + Done d -> d + | (Default | Post _) as action -> begin + (* Do the default one. Combine the successors *) + let res = + match s.succs with + [] -> E.s (E.bug "You must doStmt for the statements with no successors") + | fst :: rest -> + List.fold_left (fun acc succ -> + T.combineSuccessors acc (getStmtStartData succ)) + (getStmtStartData fst) + rest + in + (* Now do the instructions *) + let res' = + match s.skind with + Instr il -> + (* Now scan the instructions in reverse order. This may + * Stack_overflow on very long blocks ! *) + let handleInstruction (i: instr) (s: T.t) : T.t = + currentLoc := get_instrLoc i; + (* First handle the instruction itself *) + let action = T.doInstr i s in + match action with + | Done s' -> s' + | Default -> s (* do nothing *) + | Post f -> f s + in + (* Handle instructions starting with the last one *) + List.fold_right handleInstruction il res + + | _ -> res + in + match action with + Post f -> f res' + | _ -> res' + end + in + + (* See if the state has changed. The only changes are that it may grow.*) + let s0 = getStmtStartData s in + + match T.combineStmtStartData s ~old:s0 d with + None -> (* The old data is good enough *) + false + + | Some d' -> + (* We have changed the data *) + if !T.debug then + ignore (E.log "BF(%s): set data for block %d: %a\n" + T.name s.sid T.pretty d'); + IH.replace T.stmtStartData s.sid d'; + true + + + (** Compute the data flow. Must have the CFG initialized *) + let compute (sinks: stmt list) = + let worklist: Cil.stmt Queue.t = Queue.create () in + List.iter (fun s -> Queue.add s worklist) sinks; + if !T.debug && not (Queue.is_empty worklist) then + ignore (E.log "\nBF(%s): processing\n" + T.name); + let rec fixedpoint () = + if !T.debug && not (Queue.is_empty worklist) then + ignore (E.log "BF(%s): worklist= %a\n" + T.name + (docList (fun s -> num s.sid)) + (List.rev + (Queue.fold (fun acc s -> s :: acc) [] worklist))); + try + let s = Queue.take worklist in + let changes = processStmt s in + if changes then begin + (* We must add all predecessors of block b, only if not already + * in and if the filter accepts them. *) + List.iter + (fun p -> + if not (Queue.fold (fun exists s' -> exists || p.sid = s'.sid) + false worklist) && + T.filterStmt p s then + Queue.add p worklist) + s.preds; + end; + fixedpoint (); + + with Queue.Empty -> + if !T.debug then + ignore (E.log "BF(%s): done\n\n" T.name) + in + fixedpoint (); + + end + + diff --git a/cil/src/ext/dataflow.mli b/cil/src/ext/dataflow.mli new file mode 100755 index 0000000..e72c5db --- /dev/null +++ b/cil/src/ext/dataflow.mli @@ -0,0 +1,151 @@ +(** A framework for data flow analysis for CIL code. Before using + this framework, you must initialize the Control-flow Graph for your + program, e.g using {!Cfg.computeFileCFG} *) + +type 't action = + Default (** The default action *) + | Done of 't (** Do not do the default action. Use this result *) + | Post of ('t -> 't) (** The default action, followed by the given + * transformer *) + +type 't stmtaction = + SDefault (** The default action *) + | SDone (** Do not visit this statement or its successors *) + | SUse of 't (** Visit the instructions and successors of this statement + as usual, but use the specified state instead of the + one that was passed to doStmt *) + +(* For if statements *) +type 't guardaction = + GDefault (** The default state *) + | GUse of 't (** Use this data for the branch *) + | GUnreachable (** The branch will never be taken. *) + + +(****************************************************************** + ********** + ********** FORWARDS + ********** + ********************************************************************) + +module type ForwardsTransfer = sig + val name: string (** For debugging purposes, the name of the analysis *) + + val debug: bool ref (** Whether to turn on debugging *) + + type t (** The type of the data we compute for each block start. May be + * imperative. *) + + val copy: t -> t + (** Make a deep copy of the data *) + + + val stmtStartData: t Inthash.t + (** For each statement id, the data at the start. Not found in the hash + * table means nothing is known about the state at this point. At the end + * of the analysis this means that the block is not reachable. *) + + val pretty: unit -> t -> Pretty.doc + (** Pretty-print the state *) + + val computeFirstPredecessor: Cil.stmt -> t -> t + (** Give the first value for a predecessors, compute the value to be set + * for the block *) + + val combinePredecessors: Cil.stmt -> old:t -> t -> t option + (** Take some old data for the start of a statement, and some new data for + * the same point. Return None if the combination is identical to the old + * data. Otherwise, compute the combination, and return it. *) + + val doInstr: Cil.instr -> t -> t action + (** The (forwards) transfer function for an instruction. The + * {!Cil.currentLoc} is set before calling this. The default action is to + * continue with the state unchanged. *) + + val doStmt: Cil.stmt -> t -> t stmtaction + (** The (forwards) transfer function for a statement. The {!Cil.currentLoc} + * is set before calling this. The default action is to do the instructions + * in this statement, if applicable, and continue with the successors. *) + + val doGuard: Cil.exp -> t -> t guardaction + (** Generate the successor to an If statement assuming the given expression + * is nonzero. Analyses that don't need guard information can return + * GDefault; this is equivalent to returning GUse of the input. + * A return value of GUnreachable indicates that this half of the branch + * will not be taken and should not be explored. This will be called + * twice per If, once for "then" and once for "else". + *) + + val filterStmt: Cil.stmt -> bool + (** Whether to put this statement in the worklist. This is called when a + * block would normally be put in the worklist. *) + +end + +module ForwardsDataFlow (T : ForwardsTransfer) : sig + val compute: Cil.stmt list -> unit + (** Fill in the T.stmtStartData, given a number of initial statements to + * start from. All of the initial statements must have some entry in + * T.stmtStartData (i.e., the initial data should not be bottom) *) +end + +(****************************************************************** + ********** + ********** BACKWARDS + ********** + ********************************************************************) +module type BackwardsTransfer = sig + val name: string (** For debugging purposes, the name of the analysis *) + + val debug: bool ref (** Whether to turn on debugging *) + + type t (** The type of the data we compute for each block start. In many + * presentations of backwards data flow analysis we maintain the + * data at the block end. This is not easy to do with JVML because + * a block has many exceptional ends. So we maintain the data for + * the statement start. *) + + val pretty: unit -> t -> Pretty.doc (** Pretty-print the state *) + + val stmtStartData: t Inthash.t + (** For each block id, the data at the start. This data structure must be + * initialized with the initial data for each block *) + + val combineStmtStartData: Cil.stmt -> old:t -> t -> t option + (** When the analysis reaches the start of a block, combine the old data + * with the one we have just computed. Return None if the combination is + * the same as the old data, otherwise return the combination. In the + * latter case, the predecessors of the statement are put on the working + * list. *) + + + val combineSuccessors: t -> t -> t + (** Take the data from two successors and combine it *) + + + val doStmt: Cil.stmt -> t action + (** The (backwards) transfer function for a branch. The {!Cil.currentLoc} is + * set before calling this. If it returns None, then we have some default + * handling. Otherwise, the returned data is the data before the branch + * (not considering the exception handlers) *) + + val doInstr: Cil.instr -> t -> t action + (** The (backwards) transfer function for an instruction. The + * {!Cil.currentLoc} is set before calling this. If it returns None, then we + * have some default handling. Otherwise, the returned data is the data + * before the branch (not considering the exception handlers) *) + + val filterStmt: Cil.stmt -> Cil.stmt -> bool + (** Whether to put this predecessor block in the worklist. We give the + * predecessor and the block whose predecessor we are (and whose data has + * changed) *) + +end + +module BackwardsDataFlow (T : BackwardsTransfer) : sig + val compute: Cil.stmt list -> unit + (** Fill in the T.stmtStartData, given a number of initial statements to + * start from (the sinks for the backwards data flow). All of the statements + * (not just the initial ones!) must have some entry in T.stmtStartData + * (i.e., the initial data should not be bottom) *) +end diff --git a/cil/src/ext/dataslicing.ml b/cil/src/ext/dataslicing.ml new file mode 100644 index 0000000..35390b4 --- /dev/null +++ b/cil/src/ext/dataslicing.ml @@ -0,0 +1,462 @@ +(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) + +(* + * + * Copyright (c) 2004, + * Jeremy Condit + * George C. Necula + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +open Cil +open Pretty +module E = Errormsg + +let debug = false + +let numRegions : int = 2 + +let newGlobals : global list ref = ref [] + +let curFundec : fundec ref = ref dummyFunDec +let curLocation : location ref = ref locUnknown + +let applyOption (fn : 'a -> 'b) (ao : 'a option) : 'b option = + match ao with + | Some a -> Some (fn a) + | None -> None + +let getRegion (attrs : attributes) : int = + try + match List.hd (filterAttributes "region" attrs) with + | Attr (_, [AInt i]) -> i + | _ -> E.s (bug "bad region attribute") + with Failure _ -> + 1 + +let checkRegion (i : int) (attrs : attributes) : bool = + (getRegion attrs) = i + +let regionField (i : int) : string = + "r" ^ (string_of_int i) + +let regionStruct (i : int) (name : string) : string = + name ^ "_r" ^ (string_of_int i) + +let foldRegions (fn : int -> 'a -> 'a) (base : 'a) : 'a = + let rec helper (i : int) : 'a = + if i <= numRegions then + fn i (helper (i + 1)) + else + base + in + helper 1 + +let rec getTypeName (t : typ) : string = + match t with + | TVoid _ -> "void" + | TInt _ -> "int" + | TFloat _ -> "float" + | TComp (cinfo, _) -> "comp_" ^ cinfo.cname + | TNamed (tinfo, _) -> "td_" ^ tinfo.tname + | TPtr (bt, _) -> "ptr_" ^ (getTypeName bt) + | TArray (bt, _, _) -> "array_" ^ (getTypeName bt) + | TFun _ -> "fn" + | _ -> E.s (unimp "typename") + +let isAllocFunction (fn : exp) : bool = + match fn with + | Lval (Var vinfo, NoOffset) when vinfo.vname = "malloc" -> true + | _ -> false + +let isExternalFunction (fn : exp) : bool = + match fn with + | Lval (Var vinfo, NoOffset) when vinfo.vstorage = Extern -> true + | _ -> false + +let types : (int * typsig, typ) Hashtbl.t = Hashtbl.create 113 +let typeInfos : (int * string, typeinfo) Hashtbl.t = Hashtbl.create 113 +let compInfos : (int * int, compinfo) Hashtbl.t = Hashtbl.create 113 +let varTypes : (typsig, typ) Hashtbl.t = Hashtbl.create 113 +let varCompInfos : (typsig, compinfo) Hashtbl.t = Hashtbl.create 113 + +let rec sliceCompInfo (i : int) (cinfo : compinfo) : compinfo = + try + Hashtbl.find compInfos (i, cinfo.ckey) + with Not_found -> + mkCompInfo cinfo.cstruct (regionStruct i cinfo.cname) + (fun cinfo' -> + Hashtbl.add compInfos (i, cinfo.ckey) cinfo'; + List.fold_right + (fun finfo rest -> + let t = sliceType i finfo.ftype in + if not (isVoidType t) then + (finfo.fname, t, finfo.fbitfield, + finfo.fattr, finfo.floc) :: rest + else + rest) + cinfo.cfields []) + cinfo.cattr + +and sliceTypeInfo (i : int) (tinfo : typeinfo) : typeinfo = + try + Hashtbl.find typeInfos (i, tinfo.tname) + with Not_found -> + let result = + { tinfo with tname = regionStruct i tinfo.tname; + ttype = sliceType i tinfo.ttype; } + in + Hashtbl.add typeInfos (i, tinfo.tname) result; + result + +and sliceType (i : int) (t : typ) : typ = + let ts = typeSig t in + try + Hashtbl.find types (i, ts) + with Not_found -> + let result = + match t with + | TVoid _ -> t + | TInt (_, attrs) -> if checkRegion i attrs then t else TVoid [] + | TFloat (_, attrs) -> if checkRegion i attrs then t else TVoid [] + | TComp (cinfo, attrs) -> TComp (sliceCompInfo i cinfo, attrs) + | TNamed (tinfo, attrs) -> TNamed (sliceTypeInfo i tinfo, attrs) + | TPtr (TVoid _, _) -> t (* Avoid discarding void*. *) + | TPtr (bt, attrs) -> + let bt' = sliceType i bt in + if not (isVoidType bt') then TPtr (bt', attrs) else TVoid [] + | TArray (bt, eo, attrs) -> + TArray (sliceType i bt, applyOption (sliceExp 1) eo, attrs) + | TFun (ret, args, va, attrs) -> + if checkRegion i attrs then + TFun (sliceTypeAll ret, + applyOption + (List.map (fun (aname, atype, aattrs) -> + (aname, sliceTypeAll atype, aattrs))) + args, + va, attrs) + else + TVoid [] + | TBuiltin_va_list _ -> t + | _ -> E.s (unimp "type %a" d_type t) + in + Hashtbl.add types (i, ts) result; + result + +and sliceTypeAll (t : typ) : typ = + begin + match t with + | TComp (cinfo, _) when hasAttribute "var_type_sliced" cinfo.cattr -> + E.s (bug "tried to slice twice") + | _ -> () + end; + let ts = typeSig t in + try + Hashtbl.find varTypes ts + with Not_found -> + let cinfo = + let name = ("var_" ^ (getTypeName t)) in + if debug then ignore (E.log "creating %s\n" name); + try + Hashtbl.find varCompInfos ts + with Not_found -> + mkCompInfo true name + (fun cinfo -> + Hashtbl.add varCompInfos ts cinfo; + foldRegions + (fun i rest -> + let t' = sliceType i t in + if not (isVoidType t') then + (regionField i, t', None, [], !curLocation) :: rest + else + rest) + []) + [Attr ("var_type_sliced", [])] + in + let t' = + if List.length cinfo.cfields > 1 then + begin + newGlobals := GCompTag (cinfo, !curLocation) :: !newGlobals; + TComp (cinfo, []) + end + else + t + in + Hashtbl.add varTypes ts t'; + t' + +and sliceLval (i : int) (lv : lval) : lval = + if debug then ignore (E.log "lval %a\n" d_lval lv); + let lh, offset = lv in + match lh with + | Var vinfo -> + let t = sliceTypeAll vinfo.vtype in + let offset' = + match t with + | TComp (cinfo, _) when hasAttribute "var_type_sliced" cinfo.cattr -> + Field (getCompField cinfo (regionField i), offset) + | _ -> offset + in + Var vinfo, offset' + | Mem e -> + Mem (sliceExp i e), offset + +and sliceExp (i : int) (e : exp) : exp = + if debug then ignore (E.log "exp %a\n" d_exp e); + match e with + | Const c -> Const c + | Lval lv -> Lval (sliceLval i lv) + | UnOp (op, e1, t) -> UnOp (op, sliceExp i e1, sliceType i t) + | BinOp (op, e1, e2, t) -> BinOp (op, sliceExp i e1, sliceExp i e2, + sliceType i t) + | CastE (t, e) -> sliceCast i t e + | AddrOf lv -> AddrOf (sliceLval i lv) + | StartOf lv -> StartOf (sliceLval i lv) + | SizeOf t -> SizeOf (sliceTypeAll t) + | _ -> E.s (unimp "exp %a" d_exp e) + +and sliceCast (i : int) (t : typ) (e : exp) : exp = + let te = typeOf e in + match t, te with + | TInt (k1, _), TInt (k2, attrs2) when k1 = k2 -> + (* Note: We strip off integer cast operations. *) + sliceExp (getRegion attrs2) e + | TInt (k1, _), TPtr _ -> + (* Note: We strip off integer cast operations. *) + sliceExp i e + | TPtr _, _ when isZero e -> + CastE (sliceType i t, sliceExp i e) + | TPtr (bt1, _), TPtr (bt2, _) when (typeSig bt1) = (typeSig bt2) -> + CastE (sliceType i t, sliceExp i e) + | _ -> + E.s (unimp "sketchy cast (%a) -> (%a)\n" d_type te d_type t) + +and sliceExpAll (e : exp) (l : location) : instr list * exp = + let t = typeOf e in + let t' = sliceTypeAll t in + match t' with + | TComp (cinfo, _) when hasAttribute "var_type_sliced" cinfo.cattr -> + let vinfo = makeTempVar !curFundec t in + let instrs = + foldRegions + (fun i rest -> + try + let finfo = getCompField cinfo (regionField i) in + if not (isVoidType finfo.ftype) then + Set ((Var vinfo, Field (finfo, NoOffset)), + sliceExp i e, l) :: rest + else + rest + with Not_found -> + rest) + [] + in + instrs, Lval (var vinfo) + | _ -> [], sliceExp 1 e + +let sliceVar (vinfo : varinfo) : unit = + if hasAttribute "var_sliced" vinfo.vattr then + E.s (bug "tried to slice a var twice"); + let t = sliceTypeAll vinfo.vtype in + if debug then ignore (E.log "setting %s type to %a\n" vinfo.vname d_type t); + vinfo.vattr <- addAttribute (Attr ("var_sliced", [])) vinfo.vattr; + vinfo.vtype <- t + +let sliceInstr (inst : instr) : instr list = + match inst with + | Set (lv, e, loc) -> + if debug then ignore (E.log "set %a %a\n" d_lval lv d_exp e); + let t = typeOfLval lv in + foldRegions + (fun i rest -> + if not (isVoidType (sliceType i t)) then + Set (sliceLval i lv, sliceExp i e, loc) :: rest + else + rest) + [] + | Call (ret, fn, args, l) when isAllocFunction fn -> + let lv = + match ret with + | Some lv -> lv + | None -> E.s (bug "malloc call has no return lval") + in + let t = typeOfLval lv in + foldRegions + (fun i rest -> + if not (isVoidType (sliceType i t)) then + Call (Some (sliceLval i lv), sliceExp 1 fn, + List.map (sliceExp i) args, l) :: rest + else + rest) + [] + | Call (ret, fn, args, l) when isExternalFunction fn -> + [Call (applyOption (sliceLval 1) ret, sliceExp 1 fn, + List.map (sliceExp 1) args, l)] + | Call (ret, fn, args, l) -> + let ret', set = + match ret with + | Some lv -> + let vinfo = makeTempVar !curFundec (typeOfLval lv) in + Some (var vinfo), [Set (lv, Lval (var vinfo), l)] + | None -> + None, [] + in + let instrs, args' = + List.fold_right + (fun arg (restInstrs, restArgs) -> + let instrs, arg' = sliceExpAll arg l in + instrs @ restInstrs, (arg' :: restArgs)) + args ([], []) + in + instrs @ (Call (ret', sliceExp 1 fn, args', l) :: set) + | _ -> E.s (unimp "inst %a" d_instr inst) + +let sliceReturnExp (eo : exp option) (l : location) : stmtkind = + match eo with + | Some e -> + begin + match sliceExpAll e l with + | [], e' -> Return (Some e', l) + | instrs, e' -> Block (mkBlock [mkStmt (Instr instrs); + mkStmt (Return (Some e', l))]) + end + | None -> Return (None, l) + +let rec sliceStmtKind (sk : stmtkind) : stmtkind = + match sk with + | Instr instrs -> Instr (List.flatten (List.map sliceInstr instrs)) + | Block b -> Block (sliceBlock b) + | If (e, b1, b2, l) -> If (sliceExp 1 e, sliceBlock b1, sliceBlock b2, l) + | Break l -> Break l + | Continue l -> Continue l + | Return (eo, l) -> sliceReturnExp eo l + | Switch (e, b, sl, l) -> Switch (sliceExp 1 e, sliceBlock b, + List.map sliceStmt sl, l) +(* + | Loop (b, l, so1, so2) -> Loop (sliceBlock b, l, + applyOption sliceStmt so1, + applyOption sliceStmt so2) +*) + | While (e, b, l) -> While (sliceExp 1 e, sliceBlock b, l) + | DoWhile (e, b, l) -> DoWhile (sliceExp 1 e, sliceBlock b, l) + | For (bInit, e, bIter, b, l) -> + For (sliceBlock bInit, sliceExp 1e, sliceBlock bIter, sliceBlock b, l) + | Goto _ -> sk + | _ -> E.s (unimp "statement") + +and sliceStmt (s : stmt) : stmt = + (* Note: We update statements destructively so that goto/switch work. *) + s.skind <- sliceStmtKind s.skind; + s + +and sliceBlock (b : block) : block = + ignore (List.map sliceStmt b.bstmts); + b + +let sliceFundec (fd : fundec) (l : location) : unit = + curFundec := fd; + curLocation := l; + ignore (sliceBlock fd.sbody); + curFundec := dummyFunDec; + curLocation := locUnknown + +let sliceGlobal (g : global) : unit = + match g with + | GType (tinfo, l) -> + newGlobals := + foldRegions (fun i rest -> GType (sliceTypeInfo i tinfo, l) :: rest) + !newGlobals + | GCompTag (cinfo, l) -> + newGlobals := + foldRegions (fun i rest -> GCompTag (sliceCompInfo i cinfo, l) :: rest) + !newGlobals + | GCompTagDecl (cinfo, l) -> + newGlobals := + foldRegions (fun i rest -> GCompTagDecl (sliceCompInfo i cinfo, l) :: + rest) + !newGlobals + | GFun (fd, l) -> + sliceFundec fd l; + newGlobals := GFun (fd, l) :: !newGlobals + | GVarDecl _ + | GVar _ -> + (* Defer processing of vars until end. *) + newGlobals := g :: !newGlobals + | _ -> + E.s (unimp "global %a\n" d_global g) + +let sliceGlobalVars (g : global) : unit = + match g with + | GFun (fd, l) -> + curFundec := fd; + curLocation := l; + List.iter sliceVar fd.slocals; + List.iter sliceVar fd.sformals; + setFunctionType fd (sliceType 1 fd.svar.vtype); + curFundec := dummyFunDec; + curLocation := locUnknown; + | GVar (vinfo, _, l) -> + curLocation := l; + sliceVar vinfo; + curLocation := locUnknown + | _ -> () + +class dropAttrsVisitor = object + inherit nopCilVisitor + + method vvrbl (vinfo : varinfo) = + vinfo.vattr <- dropAttribute "var_sliced" vinfo.vattr; + DoChildren + + method vglob (g : global) = + begin + match g with + | GCompTag (cinfo, _) -> + cinfo.cattr <- dropAttribute "var_type_sliced" cinfo.cattr; + | _ -> () + end; + DoChildren +end + +let sliceFile (f : file) : unit = + newGlobals := []; + List.iter sliceGlobal f.globals; + List.iter sliceGlobalVars f.globals; + f.globals <- List.rev !newGlobals; + visitCilFile (new dropAttrsVisitor) f + +let feature : featureDescr = + { fd_name = "DataSlicing"; + fd_enabled = ref false; + fd_description = "data slicing"; + fd_extraopt = []; + fd_doit = sliceFile; + fd_post_check = true; + } diff --git a/cil/src/ext/dataslicing.mli b/cil/src/ext/dataslicing.mli new file mode 100644 index 0000000..0060648 --- /dev/null +++ b/cil/src/ext/dataslicing.mli @@ -0,0 +1,41 @@ +(* + * + * Copyright (c) 2001-2002, + * Jeremy Condit + * George C. Necula + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* This feature implements data slicing. The user annotates base types + * and function types with region(i) annotations, and this transformation + * will separate the fields into parallel data structures accordingly. *) + +val feature: Cil.featureDescr diff --git a/cil/src/ext/deadcodeelim.ml b/cil/src/ext/deadcodeelim.ml new file mode 100644 index 0000000..e560e01 --- /dev/null +++ b/cil/src/ext/deadcodeelim.ml @@ -0,0 +1,173 @@ +(* Eliminate assignment instructions whose results are not + used *) + +open Cil +open Pretty + +module E = Errormsg +module RD = Reachingdefs +module UD = Usedef +module IH = Inthash +module S = Stats + +module IS = Set.Make( + struct + type t = int + let compare = compare + end) + +let debug = RD.debug + + +let usedDefsSet = ref IS.empty +(* put used def ids into usedDefsSet *) +(* assumes reaching definitions have already been computed *) +class usedDefsCollectorClass = object(self) + inherit RD.rdVisitorClass + + method add_defids iosh e u = + UD.VS.iter (fun vi -> + if IH.mem iosh vi.vid then + let ios = IH.find iosh vi.vid in + if !debug then ignore(E.log "DCE: IOS size for vname=%s at stmt=%d: %d\n" + vi.vname sid (RD.IOS.cardinal ios)); + RD.IOS.iter (function + Some(i) -> + if !debug then ignore(E.log "DCE: def %d used: %a\n" i d_plainexp e); + usedDefsSet := IS.add i (!usedDefsSet) + | None -> ()) ios + else if !debug then ignore(E.log "DCE: vid %d:%s not in stm:%d iosh at %a\n" + vi.vid vi.vname sid d_plainexp e)) u + + method vexpr e = + let u = UD.computeUseExp e in + match self#get_cur_iosh() with + Some(iosh) -> self#add_defids iosh e u; DoChildren + | None -> + if !debug then ignore(E.log "DCE: use but no rd data: %a\n" d_plainexp e); + DoChildren + + method vinst i = + let handle_inst iosh i = match i with + | Asm(_,_,slvl,_,_,_) -> List.iter (fun (s,lv) -> + match lv with (Var v, off) -> + if s.[0] = '+' then + self#add_defids iosh (Lval(Var v, off)) (UD.VS.singleton v) + | _ -> ()) slvl + | _ -> () + in + begin try + cur_rd_dat <- Some(List.hd rd_dat_lst); + rd_dat_lst <- List.tl rd_dat_lst + with Failure "hd" -> () + end; + match self#get_cur_iosh() with + Some iosh -> handle_inst iosh i; DoChildren + | None -> DoChildren + +end + +(*************************************************** + * Also need to find reads from volatiles + * uses two functions I've put in ciltools which + * are basically what Zach wrote, except one is for + * types and one is for vars. Another difference is + * they filter out pointers to volatiles. This + * handles DMA + ***************************************************) +class hasVolatile flag = object (self) + inherit nopCilVisitor + method vlval l = + let tp = typeOfLval l in + if (Ciltools.is_volatile_tp tp) then flag := true; + DoChildren + method vexpr e = + DoChildren +end + +let exp_has_volatile e = + let flag = ref false in + ignore (visitCilExpr (new hasVolatile flag) e); + !flag + (***************************************************) + +let removedCount = ref 0 +(* Filter out instructions whose definition ids are not + in usedDefsSet *) +class uselessInstrElim : cilVisitor = object(self) + inherit nopCilVisitor + + method vstmt stm = + + let test (i,(_,s,iosh)) = + match i with + Call _ -> true + | Set((Var vi,NoOffset),e,_) -> + if vi.vglob || (Ciltools.is_volatile_vi vi) || (exp_has_volatile e) then true else + let _, defd = UD.computeUseDefInstr i in + let rec loop n = + if n < 0 then false else + if IS.mem (n+s) (!usedDefsSet) + then true + else loop (n-1) + in + if loop (UD.VS.cardinal defd - 1) + then true + else (incr removedCount; false) + | _ -> true + in + + let filter il stmdat = + let rd_dat_lst = RD.instrRDs il stm.sid stmdat false in + let ildatlst = List.combine il rd_dat_lst in + let ildatlst' = List.filter test ildatlst in + let (newil,_) = List.split ildatlst' in + newil + in + + match RD.getRDs stm.sid with + None -> DoChildren + | Some(_,s,iosh) -> + match stm.skind with + Instr il -> + stm.skind <- Instr(filter il ((),s,iosh)); + SkipChildren + | _ -> DoChildren + +end + +(* until fixed point is reached *) +let elim_dead_code_fp (fd : fundec) : fundec = + (* fundec -> fundec *) + let rec loop fd = + usedDefsSet := IS.empty; + removedCount := 0; + S.time "reaching definitions" RD.computeRDs fd; + ignore(visitCilFunction (new usedDefsCollectorClass :> cilVisitor) fd); + let fd' = visitCilFunction (new uselessInstrElim) fd in + if !removedCount = 0 then fd' else loop fd' + in + loop fd + +(* just once *) +let elim_dead_code (fd : fundec) : fundec = + (* fundec -> fundec *) + usedDefsSet := IS.empty; + removedCount := 0; + S.time "reaching definitions" RD.computeRDs fd; + ignore(visitCilFunction (new usedDefsCollectorClass :> cilVisitor) fd); + let fd' = visitCilFunction (new uselessInstrElim) fd in + fd' + +class deadCodeElimClass : cilVisitor = object(self) + inherit nopCilVisitor + + method vfunc fd = + let fd' = elim_dead_code fd in + ChangeTo(fd') + +end + +let dce f = + if !debug then ignore(E.log "DCE: starting dead code elimination\n"); + visitCilFile (new deadCodeElimClass) f diff --git a/cil/src/ext/dominators.ml b/cil/src/ext/dominators.ml new file mode 100755 index 0000000..d838d23 --- /dev/null +++ b/cil/src/ext/dominators.ml @@ -0,0 +1,241 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(** Compute dominator information for the statements in a function *) +open Cil +open Pretty +module E = Errormsg +module H = Hashtbl +module U = Util +module IH = Inthash + +module DF = Dataflow + +let debug = false + +(* For each statement we maintain a set of statements that dominate it *) +module BS = Set.Make(struct + type t = Cil.stmt + let compare v1 v2 = Pervasives.compare v1.sid v2.sid + end) + + + + +(** Customization module for dominators *) +module DT = struct + let name = "dom" + + let debug = ref debug + + type t = BS.t + + (** For each statement in a function we keep the set of dominator blocks. + * Indexed by statement id *) + let stmtStartData: t IH.t = IH.create 17 + + let copy (d: t) = d + + let pretty () (d: t) = + dprintf "{%a}" + (docList (fun s -> dprintf "%d" s.sid)) + (BS.elements d) + + let computeFirstPredecessor (s: stmt) (d: BS.t) : BS.t = + (* Make sure we add this block to the set *) + BS.add s d + + let combinePredecessors (s: stmt) ~(old: BS.t) (d: BS.t) : BS.t option = + (* First, add this block to the data from the predecessor *) + let d' = BS.add s d in + if BS.subset old d' then + None + else + Some (BS.inter old d') + + let doInstr (i: instr) (d: t) = DF.Default + + let doStmt (s: stmt) (d: t) = DF.SDefault + + let doGuard condition _ = DF.GDefault + + + let filterStmt _ = true +end + + + +module Dom = DF.ForwardsDataFlow(DT) + +let getStmtDominators (data: BS.t IH.t) (s: stmt) : BS.t = + try IH.find data s.sid + with Not_found -> BS.empty (* Not reachable *) + + +let getIdom (idomInfo: stmt option IH.t) (s: stmt) = + try IH.find idomInfo s.sid + with Not_found -> + E.s (E.bug "Immediate dominator information not set for statement %d" + s.sid) + +(** Check whether one block dominates another. This assumes that the "idom" + * field has been computed. *) +let rec dominates (idomInfo: stmt option IH.t) (s1: stmt) (s2: stmt) = + s1 == s2 || + (let s2idom = getIdom idomInfo s2 in + match s2idom with + None -> false + | Some s2idom -> dominates idomInfo s1 s2idom) + + + + +let computeIDom (f: fundec) : stmt option IH.t = + (* We must prepare the CFG info first *) + prepareCFG f; + computeCFGInfo f false; + + IH.clear DT.stmtStartData; + let idomData: stmt option IH.t = IH.create 13 in + + let _ = + match f.sbody.bstmts with + [] -> () (* function has no body *) + | start :: _ -> begin + (* We start with only the start block *) + IH.add DT.stmtStartData start.sid (BS.singleton start); + + Dom.compute [start]; + + (* Dump the dominators information *) + if debug then + List.iter + (fun s -> + let sdoms = getStmtDominators DT.stmtStartData s in + if not (BS.mem s sdoms) then begin + (* It can be that the block is not reachable *) + if s.preds <> [] then + E.s (E.bug "Statement %d is not in its list of dominators" + s.sid); + end; + ignore (E.log "Dominators for %d: %a\n" s.sid + DT.pretty (BS.remove s sdoms))) + f.sallstmts; + + (* Now fill the immediate dominators for all nodes *) + let rec fillOneIdom (s: stmt) = + try + ignore (IH.find idomData s.sid) + (* Already set *) + with Not_found -> begin + (* Get the dominators *) + let sdoms = getStmtDominators DT.stmtStartData s in + (* Fill the idom for the dominators first *) + let idom = + BS.fold + (fun d (sofar: stmt option) -> + if d.sid = s.sid then + sofar (* Ignore the block itself *) + else begin + (* fill the idom information recursively *) + fillOneIdom d; + match sofar with + None -> Some d + | Some sofar' -> + (* See if d is dominated by sofar. We know that the + * idom information has been computed for both sofar + * and for d*) + if dominates idomData sofar' d then + Some d + else + sofar + end) + sdoms + None + in + IH.replace idomData s.sid idom + end + in + (* Scan all blocks and compute the idom *) + List.iter fillOneIdom f.sallstmts + end + in + idomData + + + +(** Compute the start of the natural loops. For each start, keep a list of + * origin of a back edge. The loop consists of the loop start and all + * predecessors of the origins of back edges, up to and including the loop + * start *) +let findNaturalLoops (f: fundec) + (idomData: stmt option IH.t) : (stmt * stmt list) list = + let loops = + List.fold_left + (fun acc b -> + (* Iterate over all successors, and see if they are among the + * dominators for this block *) + List.fold_left + (fun acc s -> + if dominates idomData s b then + (* s is the start of a natural loop *) + let rec addNaturalLoop = function + [] -> [(s, [b])] + | (s', backs) :: rest when s'.sid = s.sid -> + (s', b :: backs) :: rest + | l :: rest -> l :: addNaturalLoop rest + in + addNaturalLoop acc + else + acc) + acc + b.succs) + [] + f.sallstmts + in + + if debug then + ignore (E.log "Natural loops:\n%a\n" + (docList ~sep:line + (fun (s, backs) -> + dprintf " Start: %d, backs:%a" + s.sid + (docList (fun b -> num b.sid)) + backs)) + loops); + + loops diff --git a/cil/src/ext/dominators.mli b/cil/src/ext/dominators.mli new file mode 100755 index 0000000..0abf82e --- /dev/null +++ b/cil/src/ext/dominators.mli @@ -0,0 +1,29 @@ + + +(** Compute dominators using data flow analysis *) +(** Author: George Necula + 5/28/2004 + **) + +(** Invoke on a code after filling in the CFG info and it computes the + * immediate dominator information. We map each statement to its immediate + * dominator (None for the start statement, and for the unreachable + * statements). *) +val computeIDom: Cil.fundec -> Cil.stmt option Inthash.t + + +(** This is like Inthash.find but gives an error if the information is + * Not_found *) +val getIdom: Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt option + +(** Check whether one statement dominates another. *) +val dominates: Cil.stmt option Inthash.t -> Cil.stmt -> Cil.stmt -> bool + + +(** Compute the start of the natural loops. This assumes that the "idom" + * field has been computed. For each start, keep a list of origin of a back + * edge. The loop consists of the loop start and all predecessors of the + * origins of back edges, up to and including the loop start *) +val findNaturalLoops: Cil.fundec -> + Cil.stmt option Inthash.t -> + (Cil.stmt * Cil.stmt list) list diff --git a/cil/src/ext/epicenter.ml b/cil/src/ext/epicenter.ml new file mode 100644 index 0000000..a8045e8 --- /dev/null +++ b/cil/src/ext/epicenter.ml @@ -0,0 +1,114 @@ +(* epicenter.ml *) +(* code for epicenter.mli *) + +(* module maintainer: scott *) +(* see copyright at end of this file *) + +open Callgraph +open Cil +open Trace +open Pretty +module H = Hashtbl +module IH = Inthash + +let sliceFile (f:file) (epicenter:string) (maxHops:int) : unit = + (* compute the static call graph *) + let graph:callgraph = (computeGraph f) in + + (* will accumulate here the set of names of functions already seen *) + let seen: (string, unit) H.t = (H.create 117) in + + (* when removing "unused" symbols, keep all seen functions *) + let isRoot : global -> bool = function + | GFun ({svar = {vname = vname}}, _) -> + H.mem seen vname + | _ -> + false + in + + (* recursive depth-first search through the call graph, finding + * all nodes within 'hops' hops of 'node' and marking them to + * to be retained *) + let rec dfs (node:callnode) (hops:int) : unit = + (* only recurse if we haven't already marked this node *) + if not (H.mem seen (nodeName node.cnInfo)) then + begin + (* add this node *) + H.add seen (nodeName node.cnInfo) (); + trace "epicenter" (dprintf "will keep %s\n" (nodeName node.cnInfo)); + + (* if we cannot do any more hops, stop *) + if (hops > 0) then + + (* recurse on all the node's callers and callees *) + let recurse _ (adjacent:callnode) : unit = + (dfs adjacent (hops - 1)) + in + IH.iter recurse node.cnCallees; + IH.iter recurse node.cnCallers + end + in + dfs (Hashtbl.find graph epicenter) maxHops; + + (* finally, throw away anything we haven't decided to keep *) + Cilutil.sliceGlobal := true; + Rmtmps.removeUnusedTemps ~isRoot:isRoot f + +let doEpicenter = ref false +let epicenterName = ref "" +let epicenterHops = ref 0 + +let feature : featureDescr = + { fd_name = "epicenter"; + fd_enabled = doEpicenter; + fd_description = "remove all functions except those within some number " ^ + "of hops (in the call graph) from a given function"; + fd_extraopt = + [ + ("--epicenter-name", + Arg.String (fun s -> epicenterName := s), + ": do an epicenter slice starting from function "); + ("--epicenter-hops", Arg.Int (fun n -> epicenterHops := n), + ": specify max # of hops for epicenter slice"); + ]; + + fd_doit = + (fun f -> + sliceFile f !epicenterName !epicenterHops); + + fd_post_check = true; + } + + +(* + * + * Copyright (c) 2001-2002 by + * George C. Necula necula@cs.berkeley.edu + * Scott McPeak smcpeak@cs.berkeley.edu + * Wes Weimer weimer@cs.berkeley.edu + * Ben Liblit liblit@cs.berkeley.edu + * + * All rights reserved. Permission to use, copy, modify and distribute + * this software for research purposes only is hereby granted, + * provided that the following conditions are met: + * 1. XSRedistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * 3. The name of the authors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * DISCLAIMER: + * THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, + * BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS + * OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON + * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) diff --git a/cil/src/ext/heap.ml b/cil/src/ext/heap.ml new file mode 100644 index 0000000..10f48a0 --- /dev/null +++ b/cil/src/ext/heap.ml @@ -0,0 +1,112 @@ +(* See copyright notice at the end of the file *) + +(* The type of a heap (priority queue): keys are integers, data values + * are whatever you like *) +type ('a) t = { + elements : (int * ('a option)) array ; + mutable size : int ; (* current number of elements *) + capacity : int ; (* max number of elements *) +} + +let create size = { + elements = Array.create (size+1) (max_int,None) ; + size = 0 ; + capacity = size ; +} + +let clear heap = heap.size <- 0 + +let is_full heap = (heap.size = heap.capacity) + +let is_empty heap = (heap.size = 0) + +let insert heap prio elt = begin + if is_full heap then begin + raise (Invalid_argument "Heap.insert") + end ; + heap.size <- heap.size + 1 ; + let i = ref heap.size in + while ( fst heap.elements.(!i / 2) < prio ) do + heap.elements.(!i) <- heap.elements.(!i / 2) ; + i := (!i / 2) + done ; + heap.elements.(!i) <- (prio,Some(elt)) + end + +let examine_max heap = + if is_empty heap then begin + raise (Invalid_argument "Heap.examine_max") + end ; + match heap.elements.(1) with + p,Some(elt) -> p,elt + | p,None -> failwith "Heap.examine_max" + +let extract_max heap = begin + if is_empty heap then begin + raise (Invalid_argument "Heap.extract_max") + end ; + let max = heap.elements.(1) in + let last = heap.elements.(heap.size) in + heap.size <- heap.size - 1 ; + let i = ref 1 in + let break = ref false in + while (!i * 2 <= heap.size) && not !break do + let child = ref (!i * 2) in + + (* find smaller child *) + if (!child <> heap.size && + fst heap.elements.(!child+1) > fst heap.elements.(!child)) then begin + incr child + end ; + + (* percolate one level *) + if (fst last < fst heap.elements.(!child)) then begin + heap.elements.(!i) <- heap.elements.(!child) ; + i := !child + end else begin + break := true + end + done ; + heap.elements.(!i) <- last ; + match max with + p,Some(elt) -> p,elt + | p,None -> failwith "Heap.examine_min" + end + + +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) diff --git a/cil/src/ext/heapify.ml b/cil/src/ext/heapify.ml new file mode 100644 index 0000000..a583181 --- /dev/null +++ b/cil/src/ext/heapify.ml @@ -0,0 +1,250 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* + * Heapify: a program transform that looks over functions, finds those + * that have local (stack) variables that contain arrays, puts all such + * local variables into a single heap allocated structure, changes all + * accesses to such variables into accesses to fields of that structure + * and frees the structure on return. + *) +open Cil + +(* utilities that should be in Cil.ml *) +(* sfg: this function appears to never be called *) +let mkSimpleField ci fn ft fl = + { fcomp = ci ; fname = fn ; ftype = ft ; fbitfield = None ; fattr = []; + floc = fl } + + +(* actual Heapify begins *) + +let heapifyNonArrays = ref false + +(* Does this local var contain an array? *) +let rec containsArray (t:typ) : bool = (* does this type contain an array? *) + match unrollType t with + TArray _ -> true + | TComp(ci, _) -> (* look at the types of the fields *) + List.exists (fun fi -> containsArray fi.ftype) ci.cfields + | _ -> + (* Ignore other types, including TInt and TPtr. We don't care whether + there are arrays in the base types of pointers; only about whether + this local variable itself needs to be moved to the heap. *) + false + + +class heapifyModifyVisitor big_struct big_struct_fields varlist free + (currentFunction: fundec) = object(self) + inherit nopCilVisitor (* visit lvalues and statements *) + method vlval l = match l with (* should we change this one? *) + Var(vi),vi_offset when List.mem_assoc vi varlist -> (* check list *) + let i = List.assoc vi varlist in (* find field offset *) + let big_struct_field = List.nth big_struct_fields i in + let new_lval = Mem(Lval(big_struct, NoOffset)), + Field(big_struct_field,vi_offset) in (* rewrite the lvalue *) + ChangeDoChildrenPost(new_lval, (fun l -> l)) + | _ -> DoChildren (* ignore other lvalues *) + method vstmt s = match s.skind with (* also rewrite the return *) + Return(None,loc) -> + let free_instr = Call(None,free,[Lval(big_struct,NoOffset)],loc) in + self#queueInstr [free_instr]; (* insert free_instr before the return *) + DoChildren + | Return(Some exp ,loc) -> + (* exp may depend on big_struct, so evaluate it before calling free. + * This becomes: tmp = exp; free(big_struct); return tmp; *) + let exp_new = visitCilExpr (self :> cilVisitor) exp in + let ret_tmp = makeTempVar currentFunction (typeOf exp_new) in + let eval_ret_instr = Set(var ret_tmp, exp_new, loc) in + let free_instr = Call(None,free,[Lval(big_struct,NoOffset)],loc) in + (* insert the instructions before the return *) + self#queueInstr [eval_ret_instr; free_instr]; + s.skind <- (Return(Some(Lval(var ret_tmp)), loc)); + DoChildren + | _ -> DoChildren (* ignore other statements *) +end + +class heapifyAnalyzeVisitor f alloc free = object + inherit nopCilVisitor (* only look at function bodies *) + method vglob gl = match gl with + GFun(fundec,funloc) -> + let counter = ref 0 in (* the number of local vars containing arrays *) + let varlist = ref [] in (* a list of (var,id) pairs, in reverse order *) + List.iter (fun vi -> + (* find all local vars with arrays. If the user requests it, + we also look for non-array vars whose address is taken. *) + if (containsArray vi.vtype) || (vi.vaddrof && !heapifyNonArrays) + then begin + varlist := (vi,!counter) :: !varlist ; (* add it to the list *) + incr counter (* put the next such var in the next slot *) + end + ) fundec.slocals ; + if (!varlist <> []) then begin (* some local vars contain arrays *) + let name = (fundec.svar.vname ^ "_heapify") in + let ci = mkCompInfo true name (* make a big structure *) + (fun _ -> List.rev_map (* reverse the list to fix the order *) + (* each local var becomes a field *) + (fun (vi,i) -> vi.vname,vi.vtype,None,[],vi.vdecl) !varlist) [] in + let vi = makeLocalVar fundec name (TPtr(TComp(ci,[]),[])) in + let modify = new heapifyModifyVisitor (Var(vi)) ci.cfields + !varlist free fundec in (* rewrite accesses to local vars *) + fundec.sbody <- visitCilBlock modify fundec.sbody ; + let alloc_stmt = mkStmt (* allocate the big struct on the heap *) + (Instr [Call(Some(Var(vi),NoOffset), alloc, + [SizeOf(TComp(ci,[]))],funloc)]) in + fundec.sbody.bstmts <- alloc_stmt :: fundec.sbody.bstmts ; + fundec.slocals <- List.filter (fun vi -> (* remove local vars *) + not (List.mem_assoc vi !varlist)) fundec.slocals ; + let typedec = (GCompTag(ci,funloc)) in (* declare the big struct *) + ChangeTo([typedec ; GFun(fundec,funloc)]) (* done! *) + end else + DoChildren (* ignore everything else *) + | _ -> DoChildren +end + +let heapify (f : file) (alloc : exp) (free : exp) = + visitCilFile (new heapifyAnalyzeVisitor f alloc free) f; + f + +(* heapify code ends here *) + +let default_heapify (f : file) = + let alloc_fun = emptyFunction "malloc" in + let free_fun = emptyFunction "free" in + let alloc_exp = (Lval((Var(alloc_fun.svar)),NoOffset)) in + let free_exp = (Lval((Var(free_fun.svar)),NoOffset)) in + ignore (heapify f alloc_exp free_exp) + +(* StackGuard clone *) + +class sgModifyVisitor restore_ra_stmt = object + inherit nopCilVisitor + method vstmt s = match s.skind with (* also rewrite the return *) + Return(_,loc) -> let new_block = mkBlock [restore_ra_stmt ; s] in + ChangeTo(mkStmt (Block(new_block))) + | _ -> DoChildren (* ignore other statements *) +end + +class sgAnalyzeVisitor f push pop get_ra set_ra = object + inherit nopCilVisitor + method vfunc fundec = + let needs_guarding = List.fold_left + (fun acc vi -> acc || containsArray vi.vtype) + false fundec.slocals in + if needs_guarding then begin + let ra_tmp = makeLocalVar fundec "return_address" voidPtrType in + let ra_exp = Lval(Var(ra_tmp),NoOffset) in + let save_ra_stmt = mkStmt (* save the current return address *) + (Instr [Call(Some(Var(ra_tmp),NoOffset), get_ra, [], locUnknown) ; + Call(None, push, [ra_exp], locUnknown)]) in + let restore_ra_stmt = mkStmt (* restore the old return address *) + (Instr [Call(Some(Var(ra_tmp),NoOffset), pop, [], locUnknown) ; + Call(None, set_ra, [ra_exp], locUnknown)]) in + let modify = new sgModifyVisitor restore_ra_stmt in + fundec.sbody <- visitCilBlock modify fundec.sbody ; + fundec.sbody.bstmts <- save_ra_stmt :: fundec.sbody.bstmts ; + ChangeTo(fundec) (* done! *) + end else DoChildren +end + +let stackguard (f : file) (push : exp) (pop : exp) + (get_ra : exp) (set_ra : exp) = + visitCilFileSameGlobals (new sgAnalyzeVisitor f push pop get_ra set_ra) f; + f + (* stackguard code ends *) + +let default_stackguard (f : file) = + let expify fundec = Lval(Var(fundec.svar),NoOffset) in + let push = expify (emptyFunction "stackguard_push") in + let pop = expify (emptyFunction "stackguard_pop") in + let get_ra = expify (emptyFunction "stackguard_get_ra") in + let set_ra = expify (emptyFunction "stackguard_set_ra") in + let global_decl = +"extern void * stackguard_get_ra(); +extern void stackguard_set_ra(void *new_ra); +/* You must provide an implementation for functions that get and set the + * return address. Such code is unfortunately architecture specific. + */ +struct stackguard_stack { + void * data; + struct stackguard_stack * next; +} * stackguard_stack; + +void stackguard_push(void *ra) { + void * old = stackguard_stack; + stackguard_stack = (struct stackguard_stack *) + malloc(sizeof(stackguard_stack)); + stackguard_stack->data = ra; + stackguard_stack->next = old; +} + +void * stackguard_pop() { + void * ret = stackguard_stack->data; + void * next = stackguard_stack->next; + free(stackguard_stack); + stackguard_stack->next = next; + return ret; +}" in + f.globals <- GText(global_decl) :: f.globals ; + ignore (stackguard f push pop get_ra set_ra ) + + +let feature1 : featureDescr = + { fd_name = "stackGuard"; + fd_enabled = Cilutil.doStackGuard; + fd_description = "instrument function calls and returns to maintain a separate stack for return addresses" ; + fd_extraopt = []; + fd_doit = (function (f: file) -> default_stackguard f); + fd_post_check = true; + } +let feature2 : featureDescr = + { fd_name = "heapify"; + fd_enabled = Cilutil.doHeapify; + fd_description = "move stack-allocated arrays to the heap" ; + fd_extraopt = [ + "--heapifyAll", Arg.Set heapifyNonArrays, + "When using heapify, move all local vars whose address is taken, not just arrays."; + ]; + fd_doit = (function (f: file) -> default_heapify f); + fd_post_check = true; + } + + + + + + diff --git a/cil/src/ext/liveness.ml b/cil/src/ext/liveness.ml new file mode 100644 index 0000000..72cd607 --- /dev/null +++ b/cil/src/ext/liveness.ml @@ -0,0 +1,190 @@ + +(* Calculate which variables are live at + * each statememnt. + * + * + * + *) + +open Cil +open Pretty + +module DF = Dataflow +module UD = Usedef +module IH = Inthash +module E = Errormsg + +let debug = ref false + +let live_label = ref "" +let live_func = ref "" + +module VS = UD.VS + +let debug_print () vs = (VS.fold + (fun vi d -> + d ++ text "name: " ++ text vi.vname + ++ text " id: " ++ num vi.vid ++ text " ") + vs nil) ++ line + +let min_print () vs = (VS.fold + (fun vi d -> + d ++ text vi.vname + ++ text "(" ++ d_type () vi.vtype ++ text ")" + ++ text ",") + vs nil) ++ line + +let printer = ref debug_print + +module LiveFlow = struct + let name = "Liveness" + let debug = debug + type t = VS.t + + let pretty () vs = + let fn = !printer in + fn () vs + + let stmtStartData = IH.create 32 + + let combineStmtStartData (stm:stmt) ~(old:t) (now:t) = + if not(VS.compare old now = 0) + then Some(VS.union old now) + else None + + let combineSuccessors = VS.union + + let doStmt stmt = + if !debug then ignore(E.log "looking at: %a\n" d_stmt stmt); + match stmt.succs with + [] -> let u,d = UD.computeUseDefStmtKind stmt.skind in + if !debug then ignore(E.log "doStmt: no succs %d\n" stmt.sid); + DF.Done u + | _ -> + let handle_stm vs = match stmt.skind with + Instr _ -> vs + | s -> let u, d = UD.computeUseDefStmtKind s in + VS.union u (VS.diff vs d) + in + DF.Post handle_stm + + let doInstr i vs = + let transform vs' = + let u,d = UD.computeUseDefInstr i in + VS.union u (VS.diff vs' d) + in + DF.Post transform + + let filterStmt stm1 stm2 = true + +end + +module L = DF.BackwardsDataFlow(LiveFlow) + +let sink_stmts = ref [] +class sinkFinderClass = object(self) + inherit nopCilVisitor + + method vstmt s = match s.succs with + [] -> (sink_stmts := s :: (!sink_stmts); + DoChildren) + | _ -> DoChildren + +end + +(* gives list of return statements from a function *) +(* fundec -> stm list *) +let find_sinks fdec = + sink_stmts := []; + ignore(visitCilFunction (new sinkFinderClass) fdec); + !sink_stmts + +(* XXX: This does not compute the best ordering to + * give to the work-list algorithm. + *) +let all_stmts = ref [] +class nullAdderClass = object(self) + inherit nopCilVisitor + + method vstmt s = + all_stmts := s :: (!all_stmts); + IH.add LiveFlow.stmtStartData s.sid VS.empty; + DoChildren + +end + +let null_adder fdec = + ignore(visitCilFunction (new nullAdderClass) fdec); + !all_stmts + +let computeLiveness fdec = + IH.clear LiveFlow.stmtStartData; + UD.onlyNoOffsetsAreDefs := false; + all_stmts := []; + let a = null_adder fdec in + L.compute a + +let print_everything () = + let d = IH.fold (fun i vs d -> + d ++ num i ++ text ": " ++ LiveFlow.pretty () vs) + LiveFlow.stmtStartData nil in + ignore(printf "%t" (fun () -> d)) + +let match_label lbl = match lbl with + Label(str,_,b) -> + if !debug then ignore(E.log "Liveness: label seen: %s\n" str); + (*b && *)(String.compare str (!live_label) = 0) +| _ -> false + +class doFeatureClass = object(self) + inherit nopCilVisitor + + method vfunc fd = + if String.compare fd.svar.vname (!live_func) = 0 then + (Cfg.clearCFGinfo fd; + ignore(Cfg.cfgFun fd); + computeLiveness fd; + if String.compare (!live_label) "" = 0 then + (printer := min_print; + print_everything(); + SkipChildren) + else DoChildren) + else SkipChildren + + method vstmt s = + if List.exists match_label s.labels then try + let vs = IH.find LiveFlow.stmtStartData s.sid in + (printer := min_print; + ignore(printf "%a" LiveFlow.pretty vs); + SkipChildren) + with Not_found -> + if !debug then ignore(E.log "Liveness: stmt: %d not found\n" s.sid); + DoChildren + else + (if List.length s.labels = 0 then + if !debug then ignore(E.log "Liveness: no label at sid=%d\n" s.sid); + DoChildren) + +end + +let do_live_feature (f:file) = + visitCilFile (new doFeatureClass) f + +let feature = + { + fd_name = "Liveness"; + fd_enabled = ref false; + fd_description = "Spit out live variables at a label"; + fd_extraopt = [ + "--live_label", + Arg.String (fun s -> live_label := s), + "Output the variables live at this label"; + "--live_func", + Arg.String (fun s -> live_func := s), + "Output the variables live at each statement in this function."; + "--live_debug", + Arg.Unit (fun n -> debug := true), + "Print lots of debugging info";]; + fd_doit = do_live_feature; + fd_post_check = false + } diff --git a/cil/src/ext/logcalls.ml b/cil/src/ext/logcalls.ml new file mode 100644 index 0000000..0cdbc15 --- /dev/null +++ b/cil/src/ext/logcalls.ml @@ -0,0 +1,268 @@ +(** See copyright notice at the end of this file *) + +(** Add printf before each function call *) + +open Pretty +open Cil +open Trace +module E = Errormsg +module H = Hashtbl + +let i = ref 0 +let name = ref "" + +(* Switches *) +let printFunctionName = ref "printf" + +let addProto = ref false + +let printf: varinfo option ref = ref None +let makePrintfFunction () : varinfo = + match !printf with + Some v -> v + | None -> begin + let v = makeGlobalVar !printFunctionName + (TFun(voidType, Some [("format", charPtrType, [])], + true, [])) in + printf := Some v; + addProto := true; + v + end + +let mkPrint (format: string) (args: exp list) : instr = + let p: varinfo = makePrintfFunction () in + Call(None, Lval(var p), (mkString format) :: args, !currentLoc) + + +let d_string (fmt : ('a,unit,doc,string) format4) : 'a = + let f (d: doc) : string = + Pretty.sprint 200 d + in + Pretty.gprintf f fmt + +let currentFunc: string ref = ref "" + +class logCallsVisitorClass = object + inherit nopCilVisitor + + (* Watch for a declaration for our printer *) + + method vinst i = begin + match i with + | Call(lo,e,al,l) -> + let pre = mkPrint (d_string "call %a\n" d_exp e) [] in + let post = mkPrint (d_string "return from %a\n" d_exp e) [] in +(* + let str1 = prefix ^ + (Pretty.sprint 800 ( Pretty.dprintf "Calling %a(%a)\n" + d_exp e + (docList ~sep:(chr ',' ++ break ) (fun arg -> + try + match unrollType (typeOf arg) with + TInt _ | TEnum _ -> dprintf "%a = %%d" d_exp arg + | TFloat _ -> dprintf "%a = %%g" d_exp arg + | TVoid _ -> text "void" + | TComp _ -> text "comp" + | _ -> dprintf "%a = %%p" d_exp arg + with _ -> dprintf "%a = %%p" d_exp arg)) al)) in + let log_args = List.filter (fun arg -> + match unrollType (typeOf arg) with + TVoid _ | TComp _ -> false + | _ -> true) al in + let str2 = prefix ^ (Pretty.sprint 800 + ( Pretty.dprintf "Returned from %a\n" d_exp e)) in + let newinst str args = ((Call (None, Lval(var printfFun.svar), + ( [ (* one ; *) mkString str ] @ args), + locUnknown)) : instr )in + let ilist = ([ (newinst str1 log_args) ; i ; (newinst str2 []) ] : instr list) in + *) + ChangeTo [ pre; i; post ] + + | _ -> DoChildren + end + method vstmt (s : stmt) = begin + match s.skind with + Return _ -> + let pre = mkPrint (d_string "exit %s\n" !currentFunc) [] in + ChangeTo (mkStmt (Block (mkBlock [ mkStmtOneInstr pre; s ]))) + | _ -> DoChildren + +(* +(Some(e),l) -> + let str = prefix ^ Pretty.sprint 800 ( Pretty.dprintf + "Return(%%p) from %s\n" funstr ) in + let newinst = ((Call (None, Lval(var printfFun.svar), + ( [ (* one ; *) mkString str ; e ]), + locUnknown)) : instr )in + let new_stmt = mkStmtOneInstr newinst in + let slist = [ new_stmt ; s ] in + (ChangeTo(mkStmt(Block(mkBlock slist)))) + | Return(None,l) -> + let str = prefix ^ (Pretty.sprint 800 ( Pretty.dprintf + "Return void from %s\n" funstr)) in + let newinst = ((Call (None, Lval(var printfFun.svar), + ( [ (* one ; *) mkString str ]), + locUnknown)) : instr )in + let new_stmt = mkStmtOneInstr newinst in + let slist = [ new_stmt ; s ] in + (ChangeTo(mkStmt(Block(mkBlock slist)))) + | _ -> DoChildren +*) + end +end + +let logCallsVisitor = new logCallsVisitorClass + + +let logCalls (f: file) : unit = + + let doGlobal = function + | GVarDecl (v, _) when v.vname = !printFunctionName -> + if !printf = None then + printf := Some v + + | GFun (fdec, loc) -> + currentFunc := fdec.svar.vname; + (* do the body *) + ignore (visitCilFunction logCallsVisitor fdec); + (* Now add the entry instruction *) + let pre = mkPrint (d_string "enter %s\n" !currentFunc) [] in + fdec.sbody <- + mkBlock [ mkStmtOneInstr pre; + mkStmt (Block fdec.sbody) ] +(* + (* debugging 'anagram', it's really nice to be able to see the strings *) + (* inside fat pointers, even if it's a bit of a hassle and a hack here *) + let isFatCharPtr (cinfo:compinfo) = + cinfo.cname="wildp_char" || + cinfo.cname="fseqp_char" || + cinfo.cname="seqp_char" in + + (* Collect expressions that denote the actual arguments *) + let actargs = + (* make lvals out of args which pass test below *) + (List.map + (fun vi -> match unrollType vi.vtype with + | TComp(cinfo, _) when isFatCharPtr(cinfo) -> + (* access the _p field for these *) + (* luckily it's called "_p" in all three fat pointer variants *) + Lval(Var(vi), Field(getCompField cinfo "_p", NoOffset)) + | _ -> + Lval(var vi)) + + (* decide which args to pass *) + (List.filter + (fun vi -> match unrollType vi.vtype with + | TPtr(TInt(k, _), _) when isCharType(k) -> + !printPtrs || !printStrings + | TComp(cinfo, _) when isFatCharPtr(cinfo) -> + !printStrings + | TVoid _ | TComp _ -> false + | TPtr _ | TArray _ | TFun _ -> !printPtrs + | _ -> true) + fdec.sformals) + ) in + + (* make a format string for printing them *) + (* sm: expanded width to 200 because I want one per line *) + let formatstr = prefix ^ (Pretty.sprint 200 + (dprintf "entering %s(%a)\n" fdec.svar.vname + (docList ~sep:(chr ',' ++ break) + (fun vi -> match unrollType vi.vtype with + | TInt _ | TEnum _ -> dprintf "%s = %%d" vi.vname + | TFloat _ -> dprintf "%s = %%g" vi.vname + | TVoid _ -> dprintf "%s = (void)" vi.vname + | TComp(cinfo, _) -> ( + if !printStrings && isFatCharPtr(cinfo) then + dprintf "%s = \"%%s\"" vi.vname + else + dprintf "%s = (comp)" vi.vname + ) + | TPtr(TInt(k, _), _) when isCharType(k) -> ( + if (!printStrings) then + dprintf "%s = \"%%s\"" vi.vname + else if (!printPtrs) then + dprintf "%s = %%p" vi.vname + else + dprintf "%s = (str)" vi.vname + ) + | TPtr _ | TArray _ | TFun _ -> ( + if (!printPtrs) then + dprintf "%s = %%p" vi.vname + else + dprintf "%s = (ptr)" vi.vname + ) + | _ -> dprintf "%s = (?type?)" vi.vname)) + fdec.sformals)) in + + i := 0 ; + name := fdec.svar.vname ; + if !allInsts then ( + let thisVisitor = new verboseLogVisitor printfFun !name prefix in + fdec.sbody <- visitCilBlock thisVisitor fdec.sbody + ); + fdec.sbody.bstmts <- + mkStmt (Instr [Call (None, Lval(var printfFun.svar), + ( (* one :: *) mkString formatstr + :: actargs), + loc)]) :: fdec.sbody.bstmts + *) + | _ -> () + in + Stats.time "logCalls" (iterGlobals f) doGlobal; + if !addProto then begin + let p = makePrintfFunction () in + E.log "Adding prototype for call logging function %s\n" p.vname; + f.globals <- GVarDecl (p, locUnknown) :: f.globals + end + +let feature : featureDescr = + { fd_name = "logcalls"; + fd_enabled = Cilutil.logCalls; + fd_description = "generation of code to log function calls"; + fd_extraopt = [ + ("--logcallprintf", Arg.String (fun s -> printFunctionName := s), + "the name of the printf function to use"); + ("--logcalladdproto", Arg.Unit (fun s -> addProto := true), + "whether to add the prototype for the printf function") + ]; + fd_doit = logCalls; + fd_post_check = true + } + +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) diff --git a/cil/src/ext/logcalls.mli b/cil/src/ext/logcalls.mli new file mode 100644 index 0000000..22a1e96 --- /dev/null +++ b/cil/src/ext/logcalls.mli @@ -0,0 +1,41 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + +(* A simple CIL transformer that inserts calls to a runtime function to log + * the call in each function *) +val feature: Cil.featureDescr diff --git a/cil/src/ext/logwrites.ml b/cil/src/ext/logwrites.ml new file mode 100644 index 0000000..3afd067 --- /dev/null +++ b/cil/src/ext/logwrites.ml @@ -0,0 +1,139 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +open Pretty +open Cil +module E = Errormsg +module H = Hashtbl + +(* David Park at Stanford points out that you cannot take the address of a + * bitfield in GCC. *) + +(* Returns true if the given lvalue offset ends in a bitfield access. *) +let rec is_bitfield lo = match lo with + | NoOffset -> false + | Field(fi,NoOffset) -> not (fi.fbitfield = None) + | Field(_,lo) -> is_bitfield lo + | Index(_,lo) -> is_bitfield lo + +(* Return an expression that evaluates to the address of the given lvalue. + * For most lvalues, this is merely AddrOf(lv). However, for bitfields + * we do some offset gymnastics. + *) +let addr_of_lv (lh,lo) = + if is_bitfield lo then begin + (* we figure out what the address would be without the final bitfield + * access, and then we add in the offset of the bitfield from the + * beginning of its enclosing comp *) + let rec split_offset_and_bitfield lo = match lo with + | NoOffset -> failwith "logwrites: impossible" + | Field(fi,NoOffset) -> (NoOffset,fi) + | Field(e,lo) -> let a,b = split_offset_and_bitfield lo in + ((Field(e,a)),b) + | Index(e,lo) -> let a,b = split_offset_and_bitfield lo in + ((Index(e,a)),b) + in + let new_lv_offset, bf = split_offset_and_bitfield lo in + let new_lv = (lh, new_lv_offset) in + let enclosing_type = TComp(bf.fcomp, []) in + let bits_offset, bits_width = + bitsOffset enclosing_type (Field(bf,NoOffset)) in + let bytes_offset = bits_offset / 8 in + let lvPtr = mkCast ~e:(mkAddrOf (new_lv)) ~newt:(charPtrType) in + (BinOp(PlusPI, lvPtr, (integer bytes_offset), ulongType)) + end else (AddrOf (lh,lo)) + +class logWriteVisitor = object + inherit nopCilVisitor + (* Create a prototype for the logging function, but don't put it in the + * file *) + val printfFun = + let fdec = emptyFunction "syslog" in + fdec.svar.vtype <- TFun(intType, + Some [ ("prio", intType, []); + ("format", charConstPtrType, []) ], + true, []); + fdec + + method vinst (i: instr) : instr list visitAction = + match i with + Set(lv, e, l) -> begin + (* Check if we need to log *) + match lv with + (Var(v), off) when not v.vglob -> SkipChildren + | _ -> let str = Pretty.sprint 80 + (Pretty.dprintf "Write %%p to 0x%%08x at %%s:%%d (%a)\n" d_lval lv) + in + ChangeTo + [ Call((None), (Lval(Var(printfFun.svar),NoOffset)), + [ one ; + mkString str ; e ; addr_of_lv lv; + mkString l.file; + integer l.line], locUnknown); + i] + end + | Call(Some lv, f, args, l) -> begin + (* Check if we need to log *) + match lv with + (Var(v), off) when not v.vglob -> SkipChildren + | _ -> let str = Pretty.sprint 80 + (Pretty.dprintf "Write retval to 0x%%08x at %%s:%%d (%a)\n" d_lval lv) + in + ChangeTo + [ Call((None), (Lval(Var(printfFun.svar),NoOffset)), + [ one ; + mkString str ; AddrOf lv; + mkString l.file; + integer l.line], locUnknown); + i] + end + | _ -> SkipChildren + +end + +let feature : featureDescr = + { fd_name = "logwrites"; + fd_enabled = Cilutil.logWrites; + fd_description = "generation of code to log memory writes"; + fd_extraopt = []; + fd_doit = + (function (f: file) -> + let lwVisitor = new logWriteVisitor in + visitCilFileSameGlobals lwVisitor f); + fd_post_check = true; + } + diff --git a/cil/src/ext/oneret.ml b/cil/src/ext/oneret.ml new file mode 100644 index 0000000..b3ce4a1 --- /dev/null +++ b/cil/src/ext/oneret.ml @@ -0,0 +1,187 @@ +(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) + +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* Make sure that there is exactly one Return statement in the whole body. + * Replace all the other returns with Goto. This is convenient if you later + * want to insert some finalizer code, since you have a precise place where + * to put it *) +open Cil +open Pretty + +module E = Errormsg + +let dummyVisitor = new nopCilVisitor + +let oneret (f: Cil.fundec) : unit = + let fname = f.svar.vname in + (* Get the return type *) + let retTyp = + match f.svar.vtype with + TFun(rt, _, _, _) -> rt + | _ -> E.s (E.bug "Function %s does not have a function type\n" + f.svar.vname) + in + (* Does it return anything ? *) + let hasRet = match unrollType retTyp with TVoid _ -> false | _ -> true in + + (* Memoize the return result variable. Use only if hasRet *) + let lastloc = ref locUnknown in + let retVar : varinfo option ref = ref None in + let getRetVar (x: unit) : varinfo = + match !retVar with + Some rv -> rv + | None -> begin + let rv = makeLocalVar f "__retres" retTyp in (* don't collide *) + retVar := Some rv; + rv + end + in + (* Remember if we have introduced goto's *) + let haveGoto = ref false in + (* Memoize the return statement *) + let retStmt : stmt ref = ref dummyStmt in + let getRetStmt (x: unit) : stmt = + if !retStmt == dummyStmt then begin + (* Must create a statement *) + let rv = + if hasRet then Some (Lval(Var (getRetVar ()), NoOffset)) else None + in + let sr = mkStmt (Return (rv, !lastloc)) in + retStmt := sr; + sr + end else + !retStmt + in + (* Now scan all the statements. Know if you are the main body of the + * function and be prepared to add new statements at the end *) + let rec scanStmts (mainbody: bool) = function + | [] when mainbody -> (* We are at the end of the function. Now it is + * time to add the return statement *) + let rs = getRetStmt () in + if !haveGoto then + rs.labels <- (Label("return_label", !lastloc, false)) :: rs.labels; + [rs] + + | [] -> [] + + | ({skind=Return (retval, l)} as s) :: rests -> + currentLoc := l; +(* + ignore (E.log "Fixing return(%a) at %a\n" + insert + (match retval with None -> text "None" + | Some e -> d_exp () e) + d_loc l); +*) + if hasRet && retval = None then + E.s (error "Found return without value in function %s\n" fname); + if not hasRet && retval <> None then + E.s (error "Found return in subroutine %s\n" fname); + (* Keep this statement because it might have labels. But change it to + * an instruction that sets the return value (if any). *) + s.skind <- begin + match retval with + Some rval -> Instr [Set((Var (getRetVar ()), NoOffset), rval, l)] + | None -> Instr [] + end; + (* See if this is the last statement in function *) + if mainbody && rests == [] then + s :: scanStmts mainbody rests + else begin + (* Add a Goto *) + let sgref = ref (getRetStmt ()) in + let sg = mkStmt (Goto (sgref, l)) in + haveGoto := true; + s :: sg :: (scanStmts mainbody rests) + end + + | ({skind=If(eb,t,e,l)} as s) :: rests -> + currentLoc := l; + s.skind <- If(eb, scanBlock false t, scanBlock false e, l); + s :: scanStmts mainbody rests +(* + | ({skind=Loop(b,l,lb1,lb2)} as s) :: rests -> + currentLoc := l; + s.skind <- Loop(scanBlock false b, l,lb1,lb2); + s :: scanStmts mainbody rests +*) + | ({skind=While(e,b,l)} as s) :: rests -> + currentLoc := l; + s.skind <- While(e, scanBlock false b, l); + s :: scanStmts mainbody rests + | ({skind=DoWhile(e,b,l)} as s) :: rests -> + currentLoc := l; + s.skind <- DoWhile(e, scanBlock false b, l); + s :: scanStmts mainbody rests + | ({skind=For(bInit,e,bIter,b,l)} as s) :: rests -> + currentLoc := l; + s.skind <- For(scanBlock false bInit, e, scanBlock false bIter, + scanBlock false b, l); + s :: scanStmts mainbody rests + | ({skind=Switch(e, b, cases, l)} as s) :: rests -> + currentLoc := l; + s.skind <- Switch(e, scanBlock false b, cases, l); + s :: scanStmts mainbody rests + | ({skind=Block b} as s) :: rests -> + s.skind <- Block (scanBlock false b); + s :: scanStmts mainbody rests + | ({skind=(Goto _ | Instr _ | Continue _ | Break _ + | TryExcept _ | TryFinally _)} as s) + :: rests -> s :: scanStmts mainbody rests + + and scanBlock (mainbody: bool) (b: block) = + { bstmts = scanStmts mainbody b.bstmts; battrs = b.battrs; } + + in + ignore (visitCilBlock dummyVisitor f.sbody) ; (* sets CurrentLoc *) + lastloc := !currentLoc ; (* last location in the function *) + f.sbody <- scanBlock true f.sbody + + +let feature : featureDescr = + { fd_name = "oneRet"; + fd_enabled = Cilutil.doOneRet; + fd_description = "make each function have at most one 'return'" ; + fd_extraopt = []; + fd_doit = (function (f: file) -> + Cil.iterGlobals f (fun glob -> match glob with + Cil.GFun(fd,_) -> oneret fd; + | _ -> ())); + fd_post_check = true; + } diff --git a/cil/src/ext/oneret.mli b/cil/src/ext/oneret.mli new file mode 100644 index 0000000..f98ab4d --- /dev/null +++ b/cil/src/ext/oneret.mli @@ -0,0 +1,44 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + +(* Make sure that there is only one Return statement in the whole body. + * Replace all the other returns with Goto. Make sure that there is a return + * if the function is supposed to return something, and it is not declared to + * not return. *) +val oneret: Cil.fundec -> unit +val feature : Cil.featureDescr diff --git a/cil/src/ext/partial.ml b/cil/src/ext/partial.ml new file mode 100644 index 0000000..4beca3f --- /dev/null +++ b/cil/src/ext/partial.ml @@ -0,0 +1,851 @@ +(* See copyright notice at the end of the file *) +(***************************************************************************** + * Partial Evaluation & Constant Folding + * + * Soundness Assumptions: + * (1) Whole program analysis. You may call functions that are not defined + * (e.g., library functions) but they may not call back. + * (2) An undefined function may not return the address of a function whose + * address is not already taken in the code I can see. + * (3) A function pointer call may only call a function that has its + * address visibly taken in the code I can see. + * + * (More assumptions in the comments below) + *****************************************************************************) +open Cil +open Pretty + +(***************************************************************************** + * A generic signature for Alias Analysis information. Used to compute the + * call graph and do symbolic execution. + ****************************************************************************) +module type AliasInfo = + sig + val can_have_the_same_value : Cil.exp -> Cil.exp -> bool + val resolve_function_pointer : Cil.exp -> (Cil.fundec list) + end + +(***************************************************************************** + * A generic signature for Symbolic Execution execution algorithms. Such + * algorithms are used below to perform constant folding and dead-code + * elimination. You write a "basic-block" symex algorithm, we'll make it + * a whole-program CFG-pruner. + ****************************************************************************) +module type Symex = + sig + type t (* the type of a symex algorithm state object *) + val empty : t (* all values unknown *) + val equal : t -> t -> bool (* are these the same? *) + val assign : t -> Cil.lval -> Cil.exp -> (Cil.exp * t) + (* incorporate an assignment, return the RHS *) + val unassign : t -> Cil.lval -> t + (* lose all information about the given lvalue: assume an + * unknown external value has been assigned to it *) + val assembly : t -> Cil.instr -> t (* handle ASM *) + val assume : t -> Cil.exp -> t (* incorporate an assumption *) + val evaluate : t -> Cil.exp -> Cil.exp (* symbolic evaluation *) + val join : (t list) -> t (* join a bunch of states *) + val call : t -> Cil.fundec -> (Cil.exp list) -> (Cil.exp list * t) + (* we are calling the given function with the given actuals *) + val return : t -> Cil.fundec -> t + (* we are returning from the given function *) + val call_to_unknown_function : t -> t + (* throw away information that may have been changed *) + val debug : t -> unit + end + +(***************************************************************************** + * A generic signature for whole-progam call graphs. + ****************************************************************************) +module type CallGraph = + sig + type t (* the type of a call graph *) + val compute : Cil.file -> t (* file for which we compute the graph *) + val can_call : t -> Cil.fundec -> (Cil.fundec list) + val can_be_called_by : t -> Cil.fundec -> (Cil.fundec list) + val fundec_of_varinfo : t -> Cil.varinfo -> Cil.fundec + end + +(***************************************************************************** + * My cheap-o Alias Analysis. Assume all expressions can have the same + * value and any function with its address taken can be the target of + * any function pointer. + * + * Soundness Assumptions: + * (1) Someone must call "find_all_functions_With_address_taken" before the + * results are valid. This is already done in the code below. + ****************************************************************************) +let all_functions_with_address_taken = ref [] +let find_all_functions_with_address_taken (f : Cil.file) = + iterGlobals f (fun g -> match g with + GFun(fd,_) -> if fd.svar.vaddrof then + all_functions_with_address_taken := fd :: + !all_functions_with_address_taken + | _ -> ()) + +module EasyAlias = + struct + let can_have_the_same_value e1 e2 = true + let resolve_function_pointer e1 = !all_functions_with_address_taken + end + +(***************************************************************************** + * My particular method for computing the Call Graph. + ****************************************************************************) +module EasyCallGraph = functor (A : AliasInfo) -> + struct + type callGraphNode = { + fd : Cil.fundec ; + mutable calledBy : Cil.fundec list ; + mutable calls : Cil.fundec list ; + } + type t = (Cil.varinfo, callGraphNode) Hashtbl.t + + let cgCreateNode cg fundec = + let newnode = { fd = fundec ; calledBy = [] ; calls = [] } in + Hashtbl.add cg fundec.svar newnode + + let cgFindNode cg svar = Hashtbl.find cg svar + + let cgAddEdge cg caller callee = + try + let n1 = cgFindNode cg caller in + let n2 = cgFindNode cg callee in + n1.calls <- n2.fd :: n1.calls ; + n1.calledBy <- n1.fd :: n1.calledBy + with _ -> () + + class callGraphVisitor cg = object + inherit nopCilVisitor + val the_fun = ref None + + method vinst i = + let _ = match i with + Call(_,Lval(Var(callee),NoOffset),_,_) -> begin + (* known function call *) + match !the_fun with + None -> failwith "callGraphVisitor: call outside of any function" + | Some(enclosing) -> cgAddEdge cg enclosing callee + end + | Call(_,e,_,_) -> begin + (* unknown function call *) + match !the_fun with + None -> failwith "callGraphVisitor: call outside of any function" + | Some(enclosing) -> let lst = A.resolve_function_pointer e in + List.iter (fun possible_target_fd -> + cgAddEdge cg enclosing possible_target_fd.svar) lst + end + | _ -> () + in SkipChildren + + method vfunc f = the_fun := Some(f.svar) ; DoChildren + end + + let compute (f : Cil.file) = + let cg = Hashtbl.create 511 in + iterGlobals f (fun g -> match g with + GFun(fd,_) -> cgCreateNode cg fd + | _ -> () + ) ; + visitCilFileSameGlobals (new callGraphVisitor cg) f ; + cg + + let can_call cg fd = + let n = cgFindNode cg fd.svar in n.calls + let can_be_called_by cg fd = + let n = cgFindNode cg fd.svar in n.calledBy + let fundec_of_varinfo cg vi = + let n = cgFindNode cg vi in n.fd + end (* END OF: module EasyCallGraph *) + +(***************************************************************************** + * Necula's Constant Folding Strategem (re-written to be applicative) + * + * Soundness Assumptions: + * (1) Inline assembly does not affect constant folding. + ****************************************************************************) +module OrderedInt = + struct + type t = int + let compare = compare + end +module IntMap = Map.Make(OrderedInt) + +module NeculaFolding = functor (A : AliasInfo) -> + struct + (* Register file. Maps identifiers of local variables to expressions. + * We also remember if the expression depends on memory or depends on + * variables that depend on memory *) + type reg = { + rvi : varinfo ; + rval : exp ; + rmem : bool + } + type t = reg IntMap.t + let empty = IntMap.empty + let equal t1 t2 = (compare t1 t2 = 0) (* use OCAML here *) + let dependsOnMem = ref false + (* Rewrite an expression based on the current register file *) + class rewriteExpClass (regFile : t) = object + inherit nopCilVisitor + method vexpr = function + | Lval (Var v, NoOffset) -> begin + try + let defined = (IntMap.find v.vid regFile) in + if (defined.rmem) then dependsOnMem := true; + (match defined.rval with + | Const(x) -> ChangeTo (defined.rval) + | _ -> DoChildren) + with Not_found -> DoChildren + end + | Lval (Mem _, _) -> dependsOnMem := true; DoChildren + | _ -> DoChildren + end + (* Rewrite an expression and return the new expression along with an + * indication of whether it depends on memory *) + let rewriteExp r (e: exp) : exp * bool = + dependsOnMem := false; + let e' = constFold true (visitCilExpr (new rewriteExpClass r) e) in + e', !dependsOnMem + let eval r e = + let new_e, depends = rewriteExp r e in + new_e + + let setMemory regFile = + (* Get a list of all mappings that depend on memory *) + let depids = ref [] in + IntMap.iter (fun id v -> if v.rmem then depids := id :: !depids) regFile; + (* And remove them from the register file *) + List.fold_left (fun acc id -> IntMap.remove id acc) regFile !depids + + let setRegister regFile (v: varinfo) ((e,b): exp * bool) = + IntMap.add v.vid { rvi = v ; rval = e ; rmem = b; } regFile + + let resetRegister regFile (id: int) = + IntMap.remove id regFile + + class findLval lv contains = object + inherit nopCilVisitor + method vlval l = + if l = lv then + (contains := true ; SkipChildren) + else + DoChildren + end + + let removeMappingsThatDependOn regFile l = + (* Get a list of all mappings that depend on l *) + let depids = ref [] in + IntMap.iter (fun id reg -> + let found = ref false in + ignore (visitCilExpr (new findLval l found) reg.rval) ; + if !found then + depids := id :: !depids + ) regFile ; + (* And remove them from the register file *) + List.fold_left (fun acc id -> IntMap.remove id acc) regFile !depids + + let assign r l e = + let (newe,b) = rewriteExp r e in + let r' = match l with + (Var v, NoOffset) -> + let r'' = setRegister r v (newe,b) in + removeMappingsThatDependOn r'' l + | (Mem _, _) -> setMemory r + | _ -> r + in newe, r' + + let unassign r l = + let r' = match l with + (Var v, NoOffset) -> + let r'' = resetRegister r v.vid in + removeMappingsThatDependOn r'' l + | (Mem _, _) -> setMemory r + | _ -> r + in r' + + let assembly r i = r (* no-op in Necula-world *) + let assume r e = r (* no-op in Necula-world *) + + let evaluate r e = + let (newe,_) = rewriteExp r e in + newe + + (* Join two symex states *) + let join2 (r1 : t) (r2 : t) = + let keep = ref [] in + IntMap.iter (fun id reg -> + try + let reg' = IntMap.find id r2 in + if reg'.rval = reg.rval && reg'.rmem = reg.rmem then + keep := (id,reg) :: !keep + with _ -> () + ) r1 ; + List.fold_left (fun acc (id,v) -> + IntMap.add id v acc) (IntMap.empty) !keep + + let join (lst : t list) = match lst with + [] -> failwith "empty list" + | r :: tl -> List.fold_left + (fun (acc : t) (elt : t) -> join2 acc elt) r tl + + let call r fd el = + let new_arg_list = ref [] in + let final_r = List.fold_left2 (fun r vi e -> + let newe, r' = assign r ((Var(vi),NoOffset)) e in + new_arg_list := newe :: !new_arg_list ; + r' + ) r fd.sformals el in + (List.rev !new_arg_list), final_r + + let return r fd = + let regFile = + List.fold_left (fun r vi -> IntMap.remove vi.vid r) r fd.sformals + in + (* Get a list of all globals *) + let depids = ref [] in + IntMap.iter (fun vid reg -> + if reg.rvi.vglob || reg.rvi.vaddrof then depids := vid :: !depids + ) regFile ; + (* And remove them from the register file *) + List.fold_left (fun acc id -> IntMap.remove id acc) regFile !depids + + + let call_to_unknown_function r = + setMemory r + + let debug r = + IntMap.iter (fun key reg -> + ignore (Pretty.printf "%s <- %a (%b)@!" reg.rvi.vname d_exp reg.rval reg.rmem) + ) r + end (* END OF: NeculaFolding *) + +(***************************************************************************** + * A transformation to make every function call end its statement. So + * { x=1; Foo(); y=1; } + * becomes at least: + * { { x=1; Foo(); } + * { y=1; } } + * But probably more like: + * { { x=1; } { Foo(); } { y=1; } } + ****************************************************************************) +let rec contains_call il = match il with + [] -> false + | Call(_) :: tl -> true + | _ :: tl -> contains_call tl + +class callBBVisitor = object + inherit nopCilVisitor + + method vstmt s = + match s.skind with + Instr(il) when contains_call il -> begin + let list_of_stmts = List.map (fun one_inst -> + mkStmtOneInstr one_inst) il in + let block = mkBlock list_of_stmts in + ChangeDoChildrenPost(s, (fun _ -> + s.skind <- Block(block) ; + s)) + end + | _ -> DoChildren + + method vvdec _ = SkipChildren + method vexpr _ = SkipChildren + method vlval _ = SkipChildren + method vtype _ = SkipChildren +end + +let calls_end_basic_blocks f = + let thisVisitor = new callBBVisitor in + visitCilFileSameGlobals thisVisitor f + +(***************************************************************************** + * A transformation that gives each variable a unique identifier. + ****************************************************************************) +class vidVisitor = object + inherit nopCilVisitor + val count = ref 0 + + method vvdec vi = + vi.vid <- !count ; + incr count ; SkipChildren +end + +let globally_unique_vids f = + let thisVisitor = new vidVisitor in + visitCilFileSameGlobals thisVisitor f + +(***************************************************************************** + * The Weimeric Partial Evaluation Data-Flow Engine + * + * This functor performs flow-sensitive, context-insensitive whole-program + * data-flow analysis with an eye toward partial evaluation and constant + * folding. + * + * Toposort the whole-program inter-procedural CFG to compute + * (1) the number of actual predecessors for each statement + * (2) the global toposort ordering + * + * Perform standard data-flow analysis (joins, etc) on the ICFG until you + * hit a fixed point. If this changed the structure of the ICFG (by + * removing an IF-branch or an empty function call), redo the whole thing. + * + * Soundness Assumptions: + * (1) A "call instruction" is the last thing in its statement. + * Use "calls_end_basic_blocks" to get this. cil/src/main.ml does + * this when you pass --makeCFG. + * (2) All variables have globally unique identifiers. + * Use "globally_unique_vids" to get this. cil/src/main.ml does + * this when you pass --makeCFG. + * (3) This may not be a strict soundness requirement, but I wrote this + * assuming that the input file has all switch/break/continue + * statements removed. + ****************************************************************************) +module MakePartial = + functor (S : Symex) -> + functor (C : CallGraph) -> + functor (A : AliasInfo) -> + struct + + let debug = false + + (* We keep this information about every statement. Ideally this should + * be put in the stmt itself, but CIL doesn't give us space. *) + type sinfo = { (* statement info *) + incoming_state : (int, S.t) Hashtbl.t ; + (* mapping from stmt.sid to Symex.state *) + reachable_preds : (int, bool) Hashtbl.t ; + (* basically a set of all of the stmt.sids that can really + * reach this statement *) + mutable last_used_state : S.t option ; + (* When we last did the Post() of this statement, what + * incoming state did we use? If our new incoming state is + * the same, we don't have to do it again. *) + mutable priority : int ; + (* Whole-program toposort priority. High means "do me first". + * The first stmt in "main()" will have the highest priority. + *) + } + let sinfo_ht = Hashtbl.create 511 + let clear_sinfo () = Hashtbl.clear sinfo_ht + + (* We construct sinfo nodes lazily: if you ask for one that isn't + * there, we build it. *) + let get_sinfo stmt = + try + Hashtbl.find sinfo_ht stmt.sid + with _ -> + let new_sinfo = { incoming_state = Hashtbl.create 3 ; + reachable_preds = Hashtbl.create 3 ; + last_used_state = None ; + priority = (-1) ; } in + Hashtbl.add sinfo_ht stmt.sid new_sinfo ; + new_sinfo + + (* Topological Sort is a DFS in which you assign a priority right as + * you finished visiting the children. While we're there we compute + * the actual number of unique predecessors for each statement. The CIL + * information may be out of date because we keep changing the CFG by + * removing IFs and whatnot. *) + let toposort_counter = ref 1 + let add_edge s1 s2 = + let si2 = get_sinfo s2 in + Hashtbl.replace si2.reachable_preds s1.sid true + + let rec toposort c stmt = + let si = get_sinfo stmt in + if si.priority >= 0 then + () (* already visited! *) + else begin + si.priority <- 0 ; (* currently visiting *) + (* handle function calls in this basic block *) + (match stmt.skind with + (Instr(il)) -> + List.iter (fun i -> + let fd_list = match i with + Call(_,Lval(Var(vi),NoOffset),_,_) -> + begin + try + let fd = C.fundec_of_varinfo c vi in + [fd] + with e -> [] (* calling external function *) + end + | Call(_,e,_,_) -> + A.resolve_function_pointer e + | _ -> [] + in + List.iter (fun fd -> + if List.length fd.sbody.bstmts > 0 then + let fun_stmt = List.hd fd.sbody.bstmts in + add_edge stmt fun_stmt ; + toposort c fun_stmt + ) fd_list + ) il + | _ -> ()); + List.iter (fun succ -> + add_edge stmt succ ; toposort c succ) stmt.succs ; + si.priority <- !toposort_counter ; + incr toposort_counter + end + + (* we set this to true whenever we eliminate an IF or otherwise + * change the CFG *) + let changed_cfg = ref false + + (* Partially evaluate / constant fold a statement. Basically this just + * asks the Symex algorithm to evaluate the RHS in the current state + * and then compute a new state that incorporates the assignment. + * + * However, we have special handling for ifs and calls. If we can + * evaluate an if predicate to a constant, we remove the if. + * + * If we are going to make a call to a function with an empty body, we + * remove the function call. *) + let partial_stmt c state stmt handle_funcall = + let result = match stmt.skind with + Instr(il) -> + let state = ref state in + let new_il = List.map (fun i -> + if debug then begin + ignore (Pretty.printf "Instr %a@!" d_instr i ) + end ; + match i with + | Set(l,e,loc) -> + let e', state' = S.assign !state l e in + state := state' ; + [Set(l,e',loc)] + | Call(lo,(Lval(Var(vi),NoOffset)),al,loc) -> + let result = begin + try + let fd = C.fundec_of_varinfo c vi in + begin + match fd.sbody.bstmts with + [] -> [] (* no point in making this call *) + | hd :: tl -> + let al', state' = S.call !state fd al in + handle_funcall stmt hd state' ; + let state'' = S.return state' fd in + state := state'' ; + [Call(lo,(Lval(Var(vi),NoOffset)),al',loc)] + end + with e -> + let state'' = S.call_to_unknown_function !state in + let al' = List.map (S.evaluate !state) al in + state := state'' ; + [Call(lo,(Lval(Var(vi),NoOffset)),al',loc)] + end in + (* handle return value *) + begin + match lo with + Some(lv) -> state := S.unassign !state lv + | _ -> () + end ; + result + | Call(lo,f,al,loc) -> + let al' = List.map (S.evaluate !state) al in + state := S.call_to_unknown_function !state ; + (match lo with + Some(lv) -> state := S.unassign !state lv + | None -> ()) ; + [Call(lo,f,al',loc)] + | Asm(_) -> state := S.assembly !state i ; [i] + ) il in + stmt.skind <- Instr(List.flatten new_il) ; + if debug then begin + ignore (Pretty.printf "New Stmt is %a@!" d_stmt stmt) ; + end ; + !state + + | If(e,b1,b2,loc) -> + let e' = S.evaluate state e in + (* Pretty.printf "%a evals to %a\n" d_exp e d_exp e' ; *) + + (* helper function to remove an IF branch *) + let remove b remains = begin + changed_cfg := true ; + (match b.bstmts with + | [] -> () + | hd :: tl -> + stmt.succs <- List.filter (fun succ -> succ.sid <> hd.sid) + stmt.succs + ) + end in + + if (e' = one) then begin + if b2.bstmts = [] && b2.battrs = [] then begin + stmt.skind <- Block(b1) ; + match b1.bstmts with + [] -> failwith "partial: completely empty if" + | hd :: tl -> stmt.succs <- [hd] + end else + stmt.skind <- Block( + { bstmts = + [ mkStmt (Block(b1)) ; + mkStmt (If(zero,b2,{bstmts=[];battrs=[];},loc)) ] ; + battrs = [] } ) ; + remove b2 b1 ; + state + end else if (e' = zero) then begin + if b1.bstmts = [] && b1.battrs = [] then begin + stmt.skind <- Block(b2) ; + match b2.bstmts with + [] -> failwith "partial: completely empty if" + | hd :: tl -> stmt.succs <- [hd] + end else + stmt.skind <- Block( + { bstmts = + [ mkStmt (Block(b2)) ; + mkStmt (If(zero,b1,{bstmts=[];battrs=[];},loc)) ] ; + battrs = [] } ) ; + remove b1 b2 ; + state + end else begin + stmt.skind <- If(e',b1,b2,loc) ; + state + end + + | Return(Some(e),loc) -> + let e' = S.evaluate state e in + stmt.skind <- Return(Some(e'),loc) ; + state + + | Block(b) -> + if debug && List.length stmt.succs > 1 then begin + ignore (Pretty.printf "(%a) has successors [%a]@!" + d_stmt stmt + (docList ~sep:(chr '@') (d_stmt ())) + stmt.succs) + end ; + state + + | _ -> state + in result + + (* + * This is the main conceptual entry-point for the partial evaluation + * data-flow functor. + *) + let dataflow (file : Cil.file) (* whole program *) + (c : C.t) (* control-flow graph *) + (initial_state : S.t) (* any assumptions? *) + (initial_stmt : Cil.stmt) (* entry point *) + = begin + (* count the total number of statements in the program *) + let num_stmts = ref 1 in + iterGlobals file (fun g -> match g with + GFun(fd,_) -> begin + match fd.smaxstmtid with + Some(i) -> if i > !num_stmts then num_stmts := i + | None -> () + end + | _ -> () + ) ; + (if debug then + Printf.printf "Dataflow: at most %d statements in program\n" !num_stmts); + + (* create a priority queue in which to store statements *) + let worklist = Heap.create !num_stmts in + + let finished = ref false in + let passes = ref 0 in + + (* add something to the work queue *) + let enqueue caller callee state = begin + let si = get_sinfo callee in + Hashtbl.replace si.incoming_state caller.sid state ; + Heap.insert worklist si.priority callee + end in + + (* we will be finished when we complete a round of data-flow that + * does not change the ICFG *) + while not !finished do + clear_sinfo () ; + incr passes ; + + (* we must recompute the ordering and the predecessor information + * because we may have changed it by removing IFs *) + (if debug then Printf.printf "Dataflow: Topological Sorting & Reachability\n" ); + toposort c initial_stmt ; + + let initial_si = get_sinfo initial_stmt in + Heap.insert worklist initial_si.priority initial_stmt ; + + while not (Heap.is_empty worklist) do + let (p,s) = Heap.extract_max worklist in + if debug then begin + ignore (Pretty.printf "Working on stmt %d (%a) %a@!" + s.sid + (docList ~sep:(chr ',' ++ break) (fun s -> dprintf "%d" s.sid)) + s.succs + d_stmt s) ; + flush stdout ; + end ; + let si = get_sinfo s in + + (* Even though this stmt is on the worklist, we may not have + * to do anything with it if the join of all of the incoming + * states is the same as the last state we used here. *) + let must_recompute, incoming_state = + begin + let list_of_incoming_states = ref [] in + Hashtbl.iter (fun true_pred_sid b -> + let this_pred_state = + try + Hashtbl.find si.incoming_state true_pred_sid + with _ -> + (* this occurs when we're evaluating a statement and we + * have not yet evaluated all of its predecessors (the + * first time we look at a loop head, say). We must be + * conservative. We'll come back later with better + * information (as we work toward the fix-point). *) + S.empty + in + if debug then begin + Printf.printf " Incoming State from %d\n" true_pred_sid ; + S.debug this_pred_state ; + flush stdout ; + end ; + list_of_incoming_states := this_pred_state :: + !list_of_incoming_states + ) si.reachable_preds ; + let merged_incoming_state = + if !list_of_incoming_states = [] then + (* this occurs when we're looking at the first statement + * in "main" -- it has no preds *) + initial_state + else + S.join !list_of_incoming_states + in + if debug then begin + Printf.printf " Merged State:\n" ; + S.debug merged_incoming_state ; + flush stdout ; + end ; + let must_recompute = match si.last_used_state with + None -> true + | Some(last) -> not (S.equal merged_incoming_state last) + in must_recompute, merged_incoming_state + end + in + if must_recompute then begin + si.last_used_state <- Some(incoming_state) ; + let outgoing_state = + (* partially evaluate and optimize the statement *) + partial_stmt c incoming_state s enqueue in + let fresh_succs = s.succs in + (* touch every successor so that we will reconsider it *) + List.iter (fun succ -> + enqueue s succ outgoing_state + ) fresh_succs ; + end else begin + if debug then begin + Printf.printf "No need to recompute.\n" + end + end + done ; + (if debug then Printf.printf "Dataflow: Pass %d Complete\n" !passes) ; + if !changed_cfg then begin + (if debug then Printf.printf "Dataflow: Restarting (CFG Changed)\n") ; + changed_cfg := false + end else + finished := true + done ; + (if debug then Printf.printf "Dataflow: Completed (%d passes)\n" !passes) + + end + + let simplify file c fd (assumptions : (Cil.lval * Cil.exp) list) = + let starting_state = List.fold_left (fun s (l,e) -> + let e',s' = S.assign s l e in + s' + ) S.empty assumptions in + dataflow file c starting_state (List.hd fd.sbody.bstmts) + + end + + +(* + * Currently our partial-eval optimizer is built out of basically nothing. + * The alias analysis is fake, the call grpah is cheap, and we're using + * George's old basic-block symex. Still, it works. + *) +(* Don't you love Functor application? *) +module BasicCallGraph = EasyCallGraph(EasyAlias) +module BasicSymex = NeculaFolding(EasyAlias) +module BasicPartial = MakePartial(BasicSymex)(BasicCallGraph)(EasyAlias) + +(* + * A very easy entry-point to partial evaluation/symbolic execution. + * You pass the Cil file and a list of assumptions (lvalue, exp pairs that + * should be treated as assignments that occur before the program starts). + * + * We partially evaluate and optimize starting from "main". The Cil.file + * is modified in place. + *) +let partial (f : Cil.file) (assumptions : (Cil.lval * Cil.exp) list) = + try + find_all_functions_with_address_taken f ; + let c = BasicCallGraph.compute f in + try + iterGlobals f (fun g -> match g with + GFun(fd,_) when fd.svar.vname = "main" -> + BasicPartial.simplify f c fd assumptions + | _ -> ()) ; + with e -> begin + Printf.printf "Error in DataFlow: %s\n" (Printexc.to_string e) ; + raise e + end + with e -> begin + Printf.printf "Error in Partial: %s\n" (Printexc.to_string e) ; + raise e + end + +let feature : featureDescr = + { fd_name = "partial"; + fd_enabled = Cilutil.doPartial; + fd_description = "interprocedural partial evaluation and constant folding" ; + fd_extraopt = []; + fd_doit = (function (f: file) -> + if not !Cilutil.makeCFG then begin + Errormsg.s (Errormsg.error "--dopartial: you must also specify --domakeCFG\n") + end ; + partial f [] ) ; + fd_post_check = false; + } + +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) diff --git a/cil/src/ext/pta/golf.ml b/cil/src/ext/pta/golf.ml new file mode 100644 index 0000000..5ea47ff --- /dev/null +++ b/cil/src/ext/pta/golf.ml @@ -0,0 +1,1657 @@ +(* + * + * Copyright (c) 2001-2002, + * John Kodumal + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(***********************************************************************) +(* *) +(* Exceptions *) +(* *) +(***********************************************************************) + +exception Inconsistent (* raised if constraint system is inconsistent *) +exception WellFormed (* raised if types are not well-formed *) +exception NoContents +exception APFound (* raised if an alias pair is found, a control + flow exception *) + + +module U = Uref +module S = Setp +module H = Hashtbl +module Q = Queue + + +(** Subtyping kinds *) +type polarity = + Pos + | Neg + | Sub + +(** Path kinds, for CFL reachability *) +type pkind = + Positive + | Negative + | Match + | Seed + +(** Context kinds -- open or closed *) +type context = + Open + | Closed + +(* A configuration is a context (open or closed) coupled with a pair + of stamps representing a state in the cartesian product DFA. *) +type configuration = context * int * int + +module ConfigHash = +struct + type t = configuration + let equal t t' = t = t' + let hash t = Hashtbl.hash t +end + +module CH = H.Make (ConfigHash) + +type config_map = unit CH.t + +(** Generic bounds *) +type 'a bound = {index : int; info : 'a U.uref} + +(** For label paths. *) +type 'a path = { + kind : pkind; + reached_global : bool; + head : 'a U.uref; + tail : 'a U.uref +} + +module Bound = +struct + type 'a t = 'a bound + let compare (x : 'a t) (y : 'a t) = + if U.equal (x.info, y.info) then x.index - y.index + else Pervasives.compare (U.deref x.info) (U.deref y.info) +end + +module Path = +struct + type 'a t = 'a path + let compare (x : 'a t) (y : 'a t) = + if U.equal (x.head, y.head) then + begin + if U.equal (x.tail, y.tail) then + begin + if x.reached_global = y.reached_global then + Pervasives.compare x.kind y.kind + else Pervasives.compare x.reached_global y.reached_global + end + else Pervasives.compare (U.deref x.tail) (U.deref y.tail) + end + else Pervasives.compare (U.deref x.head) (U.deref y.head) +end + +module B = S.Make (Bound) + +module P = S.Make (Path) + +type 'a boundset = 'a B.t + +type 'a pathset = 'a P.t + +(** Constants, which identify elements in points-to sets *) +(** jk : I'd prefer to make this an 'a constant and specialize it to varinfo + for use with the Cil frontend, but for now, this will do *) +type constant = int * string * Cil.varinfo + +module Constant = +struct + type t = constant + let compare (xid, _, _) (yid, _, _) = xid - yid +end +module C = Set.Make (Constant) + +(** Sets of constants. Set union is used when two labels containing + constant sets are unified *) +type constantset = C.t + +type lblinfo = { + mutable l_name: string; + (** either empty or a singleton, the initial location for this label *) + loc : constantset; + (** Name of this label *) + l_stamp : int; + (** Unique integer for this label *) + mutable l_global : bool; + (** True if this location is globally accessible *) + mutable aliases: constantset; + (** Set of constants (tags) for checking aliases *) + mutable p_lbounds: lblinfo boundset; + (** Set of umatched (p) lower bounds *) + mutable n_lbounds: lblinfo boundset; + (** Set of unmatched (n) lower bounds *) + mutable p_ubounds: lblinfo boundset; + (** Set of umatched (p) upper bounds *) + mutable n_ubounds: lblinfo boundset; + (** Set of unmatched (n) upper bounds *) + mutable m_lbounds: lblinfo boundset; + (** Set of matched (m) lower bounds *) + mutable m_ubounds: lblinfo boundset; + (** Set of matched (m) upper bounds *) + + mutable m_upath: lblinfo pathset; + mutable m_lpath: lblinfo pathset; + mutable n_upath: lblinfo pathset; + mutable n_lpath: lblinfo pathset; + mutable p_upath: lblinfo pathset; + mutable p_lpath: lblinfo pathset; + + mutable l_seeded : bool; + mutable l_ret : bool; + mutable l_param : bool; +} + +(** Constructor labels *) +and label = lblinfo U.uref + +(** The type of lvalues. *) +type lvalue = { + l: label; + contents: tau +} + +and vinfo = { + v_stamp : int; + v_name : string; + + mutable v_hole : (int,unit) H.t; + mutable v_global : bool; + mutable v_mlbs : tinfo boundset; + mutable v_mubs : tinfo boundset; + mutable v_plbs : tinfo boundset; + mutable v_pubs : tinfo boundset; + mutable v_nlbs : tinfo boundset; + mutable v_nubs : tinfo boundset +} + +and rinfo = { + r_stamp : int; + rl : label; + points_to : tau; + mutable r_global: bool; +} + +and finfo = { + f_stamp : int; + fl : label; + ret : tau; + mutable args : tau list; + mutable f_global : bool; +} + +and pinfo = { + p_stamp : int; + ptr : tau; + lam : tau; + mutable p_global : bool; +} + +and tinfo = Var of vinfo + | Ref of rinfo + | Fun of finfo + | Pair of pinfo + +and tau = tinfo U.uref + +type tconstraint = Unification of tau * tau + | Leq of tau * (int * polarity) * tau + + +(** Association lists, used for printing recursive types. The first element + is a type that has been visited. The second element is the string + representation of that type (so far). If the string option is set, then + this type occurs within itself, and is associated with the recursive var + name stored in the option. When walking a type, add it to an association + list. + + Example : suppose we have the constraint 'a = ref('a). The type is unified + via cyclic unification, and would loop infinitely if we attempted to print + it. What we want to do is print the type u rv. ref(rv). This is accomplished + in the following manner: + + -- ref('a) is visited. It is not in the association list, so it is added + and the string "ref(" is stored in the second element. We recurse to print + the first argument of the constructor. + + -- In the recursive call, we see that 'a (or ref('a)) is already in the + association list, so the type is recursive. We check the string option, + which is None, meaning that this is the first recurrence of the type. We + create a new recursive variable, rv and set the string option to 'rv. Next, + we prepend u rv. to the string representation we have seen before, "ref(", + and return "rv" as the string representation of this type. + + -- The string so far is "u rv.ref(". The recursive call returns, and we + complete the type by printing the result of the call, "rv", and ")" + + In a type where the recursive variable appears twice, e.g. 'a = pair('a,'a), + the second time we hit 'a, the string option will be set, so we know to + reuse the same recursive variable name. +*) +type association = tau * string ref * string option ref + +module PathHash = +struct + type t = int list + let equal t t' = t = t' + let hash t = Hashtbl.hash t +end + +module PH = H.Make (PathHash) + +(***********************************************************************) +(* *) +(* Global Variables *) +(* *) +(***********************************************************************) + +(** Print the instantiations constraints. *) +let print_constraints : bool ref = ref false + +(** If true, print all constraints (including induced) and show + additional debug output. *) +let debug = ref false + +(** Just debug all the constraints (including induced) *) +let debug_constraints = ref false + +(** Debug smart alias queries *) +let debug_aliases = ref false + +let smart_aliases = ref false + +(** If true, make the flow step a no-op *) +let no_flow = ref false + +(** If true, disable subtyping (unification at all levels) *) +let no_sub = ref false + +(** If true, treat indexed edges as regular subtyping *) +let analyze_mono = ref true + +(** A list of equality constraints. *) +let eq_worklist : tconstraint Q.t = Q.create () + +(** A list of leq constraints. *) +let leq_worklist : tconstraint Q.t = Q.create () + +let path_worklist : (lblinfo path) Q.t = Q.create () + +let path_hash : (lblinfo path) PH.t = PH.create 32 + +(** A count of the constraints introduced from the AST. Used for debugging. *) +let toplev_count = ref 0 + +(** A hashtable containing stamp pairs of labels that must be aliased. *) +let cached_aliases : (int * int,unit) H.t = H.create 64 + +(** A hashtable mapping pairs of tau's to their join node. *) +let join_cache : (int * int, tau) H.t = H.create 64 + +(***********************************************************************) +(* *) +(* Utility Functions *) +(* *) +(***********************************************************************) + +let find = U.deref + +let die s = + Printf.printf "*******\nAssertion failed: %s\n*******\n" s; + assert false + +let fresh_appsite : (unit -> int) = + let appsite_index = ref 0 in + fun () -> + incr appsite_index; + !appsite_index + +(** Generate a unique integer. *) +let fresh_index : (unit -> int) = + let counter = ref 0 in + fun () -> + incr counter; + !counter + +let fresh_stamp : (unit -> int) = + let stamp = ref 0 in + fun () -> + incr stamp; + !stamp + +(** Return a unique integer representation of a tau *) +let get_stamp (t : tau) : int = + match find t with + Var v -> v.v_stamp + | Ref r -> r.r_stamp + | Pair p -> p.p_stamp + | Fun f -> f.f_stamp + +(** Negate a polarity. *) +let negate (p : polarity) : polarity = + match p with + Pos -> Neg + | Neg -> Pos + | Sub -> die "negate" + +(** Consistency checks for inferred types *) +let pair_or_var (t : tau) = + match find t with + Pair _ -> true + | Var _ -> true + | _ -> false + +let ref_or_var (t : tau) = + match find t with + Ref _ -> true + | Var _ -> true + | _ -> false + +let fun_or_var (t : tau) = + match find t with + Fun _ -> true + | Var _ -> true + | _ -> false + + + +(** Apply [f] structurally down [t]. Guaranteed to terminate, even if [t] + is recursive *) +let iter_tau f t = + let visited : (int,tau) H.t = H.create 4 in + let rec iter_tau' t = + if H.mem visited (get_stamp t) then () else + begin + f t; + H.add visited (get_stamp t) t; + match U.deref t with + Pair p -> + iter_tau' p.ptr; + iter_tau' p.lam + | Fun f -> + List.iter iter_tau' (f.args); + iter_tau' f.ret + | Ref r -> iter_tau' r.points_to + | _ -> () + end + in + iter_tau' t + +(* Extract a label's bounds according to [positive] and [upper]. *) +let get_bounds (p :polarity ) (upper : bool) (l : label) : lblinfo boundset = + let li = find l in + match p with + Pos -> if upper then li.p_ubounds else li.p_lbounds + | Neg -> if upper then li.n_ubounds else li.n_lbounds + | Sub -> if upper then li.m_ubounds else li.m_lbounds + +let equal_tau (t : tau) (t' : tau) = + get_stamp t = get_stamp t' + +let get_label_stamp (l : label) : int = + (find l).l_stamp + +(** Return true if [t] is global (treated monomorphically) *) +let get_global (t : tau) : bool = + match find t with + Var v -> v.v_global + | Ref r -> r.r_global + | Pair p -> p.p_global + | Fun f -> f.f_global + +let is_ret_label l = (find l).l_ret || (find l).l_global (* todo - check *) + +let is_param_label l = (find l).l_param || (find l).l_global + +let is_global_label l = (find l).l_global + +let is_seeded_label l = (find l).l_seeded + +let set_global_label (l : label) (b : bool) : unit = + assert ((not (is_global_label l)) || b); + (U.deref l).l_global <- b + +(** Aliases for set_global *) +let global_tau = get_global + + +(** Get_global for lvalues *) +let global_lvalue lv = get_global lv.contents + + + +(***********************************************************************) +(* *) +(* Printing Functions *) +(* *) +(***********************************************************************) + +let string_of_configuration (c, i, i') = + let context = match c with + Open -> "O" + | Closed -> "C" + in + Printf.sprintf "(%s,%d,%d)" context i i' + +let string_of_polarity p = + match p with + Pos -> "+" + | Neg -> "-" + | Sub -> "M" + +(** Convert a label to a string, short representation *) +let string_of_label (l : label) : string = + "\"" ^ (find l).l_name ^ "\"" + +(** Return true if the element [e] is present in the association list, + according to uref equality *) +let rec assoc_list_mem (e : tau) (l : association list) = + match l with + | [] -> None + | (h, s, so) :: t -> + if U.equal (h,e) then Some (s, so) else assoc_list_mem e t + +(** Given a tau, create a unique recursive variable name. This should always + return the same name for a given tau *) +let fresh_recvar_name (t : tau) : string = + match find t with + Pair p -> "rvp" ^ string_of_int p.p_stamp + | Ref r -> "rvr" ^ string_of_int r.r_stamp + | Fun f -> "rvf" ^ string_of_int f.f_stamp + | _ -> die "fresh_recvar_name" + + +(** Return a string representation of a tau, using association lists. *) +let string_of_tau (t : tau) : string = + let tau_map : association list ref = ref [] in + let rec string_of_tau' t = + match assoc_list_mem t !tau_map with + Some (s, so) -> (* recursive type. see if a var name has been set *) + begin + match !so with + None -> + let rv = fresh_recvar_name t in + s := "u " ^ rv ^ "." ^ !s; + so := Some rv; + rv + | Some rv -> rv + end + | None -> (* type's not recursive. Add it to the assoc list and cont. *) + let s = ref "" + and so : string option ref = ref None in + tau_map := (t, s, so) :: !tau_map; + begin + match find t with + Var v -> s := v.v_name; + | Pair p -> + assert (ref_or_var p.ptr); + assert (fun_or_var p.lam); + s := "{"; + s := !s ^ string_of_tau' p.ptr; + s := !s ^ ","; + s := !s ^ string_of_tau' p.lam; + s := !s ^"}" + | Ref r -> + assert (pair_or_var r.points_to); + s := "ref(|"; + s := !s ^ string_of_label r.rl; + s := !s ^ "|,"; + s := !s ^ string_of_tau' r.points_to; + s := !s ^ ")" + | Fun f -> + assert (pair_or_var f.ret); + let rec string_of_args = function + h :: [] -> + assert (pair_or_var h); + s := !s ^ string_of_tau' h + | h :: t -> + assert (pair_or_var h); + s := !s ^ string_of_tau' h ^ ","; + string_of_args t + | [] -> () + in + s := "fun(|"; + s := !s ^ string_of_label f.fl; + s := !s ^ "|,"; + s := !s ^ "<"; + if List.length f.args > 0 then string_of_args f.args + else s := !s ^ "void"; + s := !s ^">,"; + s := !s ^ string_of_tau' f.ret; + s := !s ^ ")" + end; + tau_map := List.tl !tau_map; + !s + in + string_of_tau' t + +(** Convert an lvalue to a string *) +let rec string_of_lvalue (lv : lvalue) : string = + let contents = string_of_tau lv.contents + and l = string_of_label lv.l in + assert (pair_or_var lv.contents); (* do a consistency check *) + Printf.sprintf "[%s]^(%s)" contents l + +let print_path (p : lblinfo path) : unit = + let string_of_pkind = function + Positive -> "p" + | Negative -> "n" + | Match -> "m" + | Seed -> "s" + in + Printf.printf + "%s --%s--> %s (%d) : " + (string_of_label p.head) + (string_of_pkind p.kind) + (string_of_label p.tail) + (PathHash.hash p) + +(** Print a list of tau elements, comma separated *) +let rec print_tau_list (l : tau list) : unit = + let rec print_t_strings = function + h :: [] -> print_endline h + | h :: t -> + print_string h; + print_string ", "; + print_t_strings t + | [] -> () + in + print_t_strings (List.map string_of_tau l) + +let print_constraint (c : tconstraint) = + match c with + Unification (t, t') -> + let lhs = string_of_tau t + and rhs = string_of_tau t' in + Printf.printf "%s == %s\n" lhs rhs + | Leq (t, (i, p), t') -> + let lhs = string_of_tau t + and rhs = string_of_tau t' in + Printf.printf "%s <={%d,%s} %s\n" lhs i (string_of_polarity p) rhs + +(***********************************************************************) +(* *) +(* Type Operations -- these do not create any constraints *) +(* *) +(***********************************************************************) + +(** Create an lvalue with label [lbl] and tau contents [t]. *) +let make_lval (lbl, t : label * tau) : lvalue = + {l = lbl; contents = t} + +let make_label_int (is_global : bool) (name :string) (vio : Cil.varinfo option) : label = + let locc = + match vio with + Some vi -> C.add (fresh_index (), name, vi) C.empty + | None -> C.empty + in + U.uref { + l_name = name; + l_global = is_global; + l_stamp = fresh_stamp (); + loc = locc; + aliases = locc; + p_ubounds = B.empty; + p_lbounds = B.empty; + n_ubounds = B.empty; + n_lbounds = B.empty; + m_ubounds = B.empty; + m_lbounds = B.empty; + m_upath = P.empty; + m_lpath = P.empty; + n_upath = P.empty; + n_lpath = P.empty; + p_upath = P.empty; + p_lpath = P.empty; + l_seeded = false; + l_ret = false; + l_param = false + } + +(** Create a new label with name [name]. Also adds a fresh constant + with name [name] to this label's aliases set. *) +let make_label (is_global : bool) (name : string) (vio : Cil.varinfo option) : label = + make_label_int is_global name vio + +(** Create a new label with an unspecified name and an empty alias set. *) +let fresh_label (is_global : bool) : label = + let index = fresh_index () in + make_label_int is_global ("l_" ^ string_of_int index) None + +(** Create a fresh bound (edge in the constraint graph). *) +let make_bound (i, a : int * label) : lblinfo bound = + {index = i; info = a} + +let make_tau_bound (i, a : int * tau) : tinfo bound = + {index = i; info = a} + +(** Create a fresh named variable with name '[name]. *) +let make_var (b: bool) (name : string) : tau = + U.uref (Var {v_name = ("'" ^ name); + v_hole = H.create 8; + v_stamp = fresh_index (); + v_global = b; + v_mlbs = B.empty; + v_mubs = B.empty; + v_plbs = B.empty; + v_pubs = B.empty; + v_nlbs = B.empty; + v_nubs = B.empty}) + +(** Create a fresh unnamed variable (name will be 'fv). *) +let fresh_var (is_global : bool) : tau = + make_var is_global ("fv" ^ string_of_int (fresh_index ())) + +(** Create a fresh unnamed variable (name will be 'fi). *) +let fresh_var_i (is_global : bool) : tau = + make_var is_global ("fi" ^ string_of_int (fresh_index())) + +(** Create a Fun constructor. *) +let make_fun (lbl, a, r : label * (tau list) * tau) : tau = + U.uref (Fun {fl = lbl; + f_stamp = fresh_index (); + f_global = false; + args = a; + ret = r }) + +(** Create a Ref constructor. *) +let make_ref (lbl,pt : label * tau) : tau = + U.uref (Ref {rl = lbl; + r_stamp = fresh_index (); + r_global = false; + points_to = pt}) + +(** Create a Pair constructor. *) +let make_pair (p,f : tau * tau) : tau = + U.uref (Pair {ptr = p; + p_stamp = fresh_index (); + p_global = false; + lam = f}) + +(** Copy the toplevel constructor of [t], putting fresh variables in each + argement of the constructor. *) +let copy_toplevel (t : tau) : tau = + match find t with + Pair _ -> make_pair (fresh_var_i false, fresh_var_i false) + | Ref _ -> make_ref (fresh_label false, fresh_var_i false) + | Fun f -> + let fresh_fn = fun _ -> fresh_var_i false in + make_fun (fresh_label false, + List.map fresh_fn f.args, fresh_var_i false) + | _ -> die "copy_toplevel" + + +let has_same_structure (t : tau) (t' : tau) = + match find t, find t' with + Pair _, Pair _ -> true + | Ref _, Ref _ -> true + | Fun _, Fun _ -> true + | Var _, Var _ -> true + | _ -> false + + +let pad_args (f, f' : finfo * finfo) : unit = + let padding = ref ((List.length f.args) - (List.length f'.args)) + in + if !padding == 0 then () + else + let to_pad = + if !padding > 0 then f' else (padding := -(!padding); f) + in + for i = 1 to !padding do + to_pad.args <- to_pad.args @ [fresh_var false] + done + + +let pad_args2 (fi, tlr : finfo * tau list ref) : unit = + let padding = ref (List.length fi.args - List.length !tlr) + in + if !padding == 0 then () + else + if !padding > 0 then + for i = 1 to !padding do + tlr := !tlr @ [fresh_var false] + done + else + begin + padding := -(!padding); + for i = 1 to !padding do + fi.args <- fi.args @ [fresh_var false] + done + end + +(***********************************************************************) +(* *) +(* Constraint Generation/ Resolution *) +(* *) +(***********************************************************************) + + +(** Make the type a global type *) +let set_global (t : tau) (b : bool) : unit = + let set_global_down t = + match find t with + Var v -> v.v_global <- true + | Ref r -> set_global_label r.rl true + | Fun f -> set_global_label f.fl true + | _ -> () + in + if !debug && b then Printf.printf "Set global: %s\n" (string_of_tau t); + assert ((not (get_global t)) || b); + if b then iter_tau set_global_down t; + match find t with + Var v -> v.v_global <- b + | Ref r -> r.r_global <- b + | Pair p -> p.p_global <- b + | Fun f -> f.f_global <- b + + +let rec unify_int (t, t' : tau * tau) : unit = + if equal_tau t t' then () + else + let ti, ti' = find t, find t' in + U.unify combine (t, t'); + match ti, ti' with + Var v, Var v' -> + set_global t' (v.v_global || get_global t'); + merge_vholes (v, v'); + merge_vlbs (v, v'); + merge_vubs (v, v') + | Var v, _ -> + set_global t' (v.v_global || get_global t'); + trigger_vhole v t'; + notify_vlbs t v; + notify_vubs t v + | _, Var v -> + set_global t (v.v_global || get_global t); + trigger_vhole v t; + notify_vlbs t' v; + notify_vubs t' v + | Ref r, Ref r' -> + set_global t (r.r_global || r'.r_global); + unify_ref (r, r') + | Fun f, Fun f' -> + set_global t (f.f_global || f'.f_global); + unify_fun (f, f') + | Pair p, Pair p' -> () + | _ -> raise Inconsistent +and notify_vlbs (t : tau) (vi : vinfo) : unit = + let notify p bounds = + List.iter + (fun b -> + add_constraint (Unification (b.info,copy_toplevel t)); + add_constraint (Leq (b.info, (b.index, p), t))) + bounds + in + notify Sub (B.elements vi.v_mlbs); + notify Pos (B.elements vi.v_plbs); + notify Neg (B.elements vi.v_nlbs) +and notify_vubs (t : tau) (vi : vinfo) : unit = + let notify p bounds = + List.iter + (fun b -> + add_constraint (Unification (b.info,copy_toplevel t)); + add_constraint (Leq (t, (b.index, p), b.info))) + bounds + in + notify Sub (B.elements vi.v_mubs); + notify Pos (B.elements vi.v_pubs); + notify Neg (B.elements vi.v_nubs) +and unify_ref (ri,ri' : rinfo * rinfo) : unit = + add_constraint (Unification (ri.points_to, ri'.points_to)) +and unify_fun (fi, fi' : finfo * finfo) : unit = + let rec union_args = function + _, [] -> false + | [], _ -> true + | h :: t, h' :: t' -> + add_constraint (Unification (h, h')); + union_args(t, t') + in + unify_label(fi.fl, fi'.fl); + add_constraint (Unification (fi.ret, fi'.ret)); + if union_args (fi.args, fi'.args) then fi.args <- fi'.args; +and unify_label (l, l' : label * label) : unit = + let pick_name (li, li' : lblinfo * lblinfo) = + if String.length li.l_name > 1 && String.sub (li.l_name) 0 2 = "l_" then + li.l_name <- li'.l_name + else () + in + let combine_label (li, li' : lblinfo *lblinfo) : lblinfo = + let rm_self b = not (li.l_stamp = get_label_stamp b.info) + in + pick_name (li, li'); + li.l_global <- li.l_global || li'.l_global; + li.aliases <- C.union li.aliases li'.aliases; + li.p_ubounds <- B.union li.p_ubounds li'.p_ubounds; + li.p_lbounds <- B.union li.p_lbounds li'.p_lbounds; + li.n_ubounds <- B.union li.n_ubounds li'.n_ubounds; + li.n_lbounds <- B.union li.n_lbounds li'.n_lbounds; + li.m_ubounds <- B.union li.m_ubounds (B.filter rm_self li'.m_ubounds); + li.m_lbounds <- B.union li.m_lbounds (B.filter rm_self li'.m_lbounds); + li.m_upath <- P.union li.m_upath li'.m_upath; + li.m_lpath<- P.union li.m_lpath li'.m_lpath; + li.n_upath <- P.union li.n_upath li'.n_upath; + li.n_lpath <- P.union li.n_lpath li'.n_lpath; + li.p_upath <- P.union li.p_upath li'.p_upath; + li.p_lpath <- P.union li.p_lpath li'.p_lpath; + li.l_seeded <- li.l_seeded || li'.l_seeded; + li.l_ret <- li.l_ret || li'.l_ret; + li.l_param <- li.l_param || li'.l_param; + li + in + if !debug_constraints then + Printf.printf "%s == %s\n" (string_of_label l) (string_of_label l'); + U.unify combine_label (l, l') +and merge_vholes (vi, vi' : vinfo * vinfo) : unit = + H.iter + (fun i -> fun _ -> H.replace vi'.v_hole i ()) + vi.v_hole +and merge_vlbs (vi, vi' : vinfo * vinfo) : unit = + vi'.v_mlbs <- B.union vi.v_mlbs vi'.v_mlbs; + vi'.v_plbs <- B.union vi.v_plbs vi'.v_plbs; + vi'.v_nlbs <- B.union vi.v_nlbs vi'.v_nlbs +and merge_vubs (vi, vi' : vinfo * vinfo) : unit = + vi'.v_mubs <- B.union vi.v_mubs vi'.v_mubs; + vi'.v_pubs <- B.union vi.v_pubs vi'.v_pubs; + vi'.v_nubs <- B.union vi.v_nubs vi'.v_nubs +and trigger_vhole (vi : vinfo) (t : tau) = + let add_self_loops (t : tau) : unit = + match find t with + Var v -> + H.iter + (fun i -> fun _ -> H.replace v.v_hole i ()) + vi.v_hole + | Ref r -> + H.iter + (fun i -> fun _ -> + leq_label (r.rl, (i, Pos), r.rl); + leq_label (r.rl, (i, Neg), r.rl)) + vi.v_hole + | Fun f -> + H.iter + (fun i -> fun _ -> + leq_label (f.fl, (i, Pos), f.fl); + leq_label (f.fl, (i, Neg), f.fl)) + vi.v_hole + | _ -> () + in + iter_tau add_self_loops t +(** Pick the representative info for two tinfo's. This function prefers the + first argument when both arguments are the same structure, but when + one type is a structure and the other is a var, it picks the structure. + All other actions (e.g., updating the info) is done in unify_int *) +and combine (ti, ti' : tinfo * tinfo) : tinfo = + match ti, ti' with + Var _, _ -> ti' + | _, _ -> ti +and leq_int (t, (i, p), t') : unit = + if equal_tau t t' then () + else + let ti, ti' = find t, find t' in + match ti, ti' with + Var v, Var v' -> + begin + match p with + Pos -> + v.v_pubs <- B.add (make_tau_bound (i, t')) v.v_pubs; + v'.v_plbs <- B.add (make_tau_bound (i, t)) v'.v_plbs + | Neg -> + v.v_nubs <- B.add (make_tau_bound (i, t')) v.v_nubs; + v'.v_nlbs <- B.add (make_tau_bound (i, t)) v'.v_nlbs + | Sub -> + v.v_mubs <- B.add (make_tau_bound (i, t')) v.v_mubs; + v'.v_mlbs <- B.add (make_tau_bound (i, t)) v'.v_mlbs + end + | Var v, _ -> + add_constraint (Unification (t, copy_toplevel t')); + add_constraint (Leq (t, (i, p), t')) + | _, Var v -> + add_constraint (Unification (t', copy_toplevel t)); + add_constraint (Leq (t, (i, p), t')) + | Ref r, Ref r' -> leq_ref (r, (i, p), r') + | Fun f, Fun f' -> add_constraint (Unification (t, t')) + | Pair pr, Pair pr' -> + add_constraint (Leq (pr.ptr, (i, p), pr'.ptr)); + add_constraint (Leq (pr.lam, (i, p), pr'.lam)) + | _ -> raise Inconsistent +and leq_ref (ri, (i, p), ri') : unit = + let add_self_loops (t : tau) : unit = + match find t with + Var v -> H.replace v.v_hole i () + | Ref r -> + leq_label (r.rl, (i, Pos), r.rl); + leq_label (r.rl, (i, Neg), r.rl) + | Fun f -> + leq_label (f.fl, (i, Pos), f.fl); + leq_label (f.fl, (i, Neg), f.fl) + | _ -> () + in + iter_tau add_self_loops ri.points_to; + add_constraint (Unification (ri.points_to, ri'.points_to)); + leq_label(ri.rl, (i, p), ri'.rl) +and leq_label (l,(i, p), l') : unit = + if !debug_constraints then + Printf.printf + "%s <={%d,%s} %s\n" + (string_of_label l) i (string_of_polarity p) (string_of_label l'); + let li, li' = find l, find l' in + match p with + Pos -> + li.l_ret <- true; + li.p_ubounds <- B.add (make_bound (i, l')) li.p_ubounds; + li'.p_lbounds <- B.add (make_bound (i, l)) li'.p_lbounds + | Neg -> + li'.l_param <- true; + li.n_ubounds <- B.add (make_bound (i, l')) li.n_ubounds; + li'.n_lbounds <- B.add (make_bound (i, l)) li'.n_lbounds + | Sub -> + if U.equal (l, l') then () + else + begin + li.m_ubounds <- B.add (make_bound(0, l')) li.m_ubounds; + li'.m_lbounds <- B.add (make_bound(0, l)) li'.m_lbounds + end +and add_constraint_int (c : tconstraint) (toplev : bool) = + if !debug_constraints && toplev then + begin + Printf.printf "%d:>" !toplev_count; + print_constraint c; + incr toplev_count + end + else + if !debug_constraints then print_constraint c else (); + begin + match c with + Unification _ -> Q.add c eq_worklist + | Leq _ -> Q.add c leq_worklist + end; + solve_constraints () +and add_constraint (c : tconstraint) = + add_constraint_int c false +and add_toplev_constraint (c : tconstraint) = + if !print_constraints && not !debug_constraints then + begin + Printf.printf "%d:>" !toplev_count; + incr toplev_count; + print_constraint c + end + else (); + add_constraint_int c true +and fetch_constraint () : tconstraint option = + try Some (Q.take eq_worklist) + with Q.Empty -> (try Some (Q.take leq_worklist) + with Q.Empty -> None) +(** The main solver loop. *) +and solve_constraints () : unit = + match fetch_constraint () with + Some c -> + begin + match c with + Unification (t, t') -> unify_int (t, t') + | Leq (t, (i, p), t') -> + if !no_sub then unify_int (t, t') + else + if !analyze_mono then leq_int (t, (0, Sub), t') + else leq_int (t, (i, p), t') + end; + solve_constraints () + | None -> () + + +(***********************************************************************) +(* *) +(* Interface Functions *) +(* *) +(***********************************************************************) + +(** Return the contents of the lvalue. *) +let rvalue (lv : lvalue) : tau = + lv.contents + +(** Dereference the rvalue. If it does not have enough structure to support + the operation, then the correct structure is added via new unification + constraints. *) +let rec deref (t : tau) : lvalue = + match U.deref t with + Pair p -> + begin + match U.deref p.ptr with + Var _ -> + let is_global = global_tau p.ptr in + let points_to = fresh_var is_global in + let l = fresh_label is_global in + let r = make_ref (l, points_to) + in + add_toplev_constraint (Unification (p.ptr, r)); + make_lval (l, points_to) + | Ref r -> make_lval (r.rl, r.points_to) + | _ -> raise WellFormed + end + | Var v -> + let is_global = global_tau t in + add_toplev_constraint + (Unification (t, make_pair (fresh_var is_global, + fresh_var is_global))); + deref t + | _ -> raise WellFormed + +(** Form the union of [t] and [t'], if it doesn't exist already. *) +let join (t : tau) (t' : tau) : tau = + try H.find join_cache (get_stamp t, get_stamp t') + with Not_found -> + let t'' = fresh_var false in + add_toplev_constraint (Leq (t, (0, Sub), t'')); + add_toplev_constraint (Leq (t', (0, Sub), t'')); + H.add join_cache (get_stamp t, get_stamp t') t''; + t'' + +(** Form the union of a list [tl], expected to be the initializers of some + structure or array type. *) +let join_inits (tl : tau list) : tau = + let t' = fresh_var false in + List.iter + (fun t -> add_toplev_constraint (Leq (t, (0, Sub), t'))) + tl; + t' + +(** Take the address of an lvalue. Does not add constraints. *) +let address (lv : lvalue) : tau = + make_pair (make_ref (lv.l, lv.contents), fresh_var false) + +(** For this version of golf, instantiation is handled at [apply] *) +let instantiate (lv : lvalue) (i : int) : lvalue = + lv + +(** Constraint generated from assigning [t] to [lv]. *) +let assign (lv : lvalue) (t : tau) : unit = + add_toplev_constraint (Leq (t, (0, Sub), lv.contents)) + +let assign_ret (i : int) (lv : lvalue) (t : tau) : unit = + add_toplev_constraint (Leq (t, (i, Pos), lv.contents)) + +(** Project out the first (ref) component or a pair. If the argument [t] has + no discovered structure, raise NoContents. *) +let proj_ref (t : tau) : tau = + match U.deref t with + Pair p -> p.ptr + | Var v -> raise NoContents + | _ -> raise WellFormed + +(* Project out the second (fun) component of a pair. If the argument [t] has + no discovered structure, create it on the fly by adding constraints. *) +let proj_fun (t : tau) : tau = + match U.deref t with + Pair p -> p.lam + | Var v -> + let p, f = fresh_var false, fresh_var false in + add_toplev_constraint (Unification (t, make_pair(p, f))); + f + | _ -> raise WellFormed + +let get_args (t : tau) : tau list = + match U.deref t with + Fun f -> f.args + | _ -> raise WellFormed + +let get_finfo (t : tau) : finfo = + match U.deref t with + Fun f -> f + | _ -> raise WellFormed + +(** Function type [t] is applied to the arguments [actuals]. Unifies the + actuals with the formals of [t]. If no functions have been discovered for + [t] yet, create a fresh one and unify it with t. The result is the return + value of the function plus the index of this application site. *) +let apply (t : tau) (al : tau list) : (tau * int) = + let i = fresh_appsite () in + let f = proj_fun t in + let actuals = ref al in + let fi,ret = + match U.deref f with + Fun fi -> fi, fi.ret + | Var v -> + let new_l, new_ret, new_args = + fresh_label false, fresh_var false, + List.map (function _ -> fresh_var false) !actuals + in + let new_fun = make_fun (new_l, new_args, new_ret) in + add_toplev_constraint (Unification (new_fun, f)); + (get_finfo new_fun, new_ret) + | _ -> raise WellFormed + in + pad_args2 (fi, actuals); + List.iter2 + (fun actual -> fun formal -> + add_toplev_constraint (Leq (actual,(i, Neg), formal))) + !actuals fi.args; + (ret, i) + +(** Create a new function type with name [name], list of formal arguments + [formals], and return value [ret]. Adds no constraints. *) +let make_function (name : string) (formals : lvalue list) (ret : tau) : tau = + let f = make_fun (make_label false name None, + List.map (fun x -> rvalue x) formals, + ret) + in + make_pair (fresh_var false, f) + +(** Create an lvalue. If [is_global] is true, the lvalue will be treated + monomorphically. *) +let make_lvalue (is_global : bool) (name : string) (vio : Cil.varinfo option) : lvalue = + if !debug && is_global then + Printf.printf "Making global lvalue : %s\n" name + else (); + make_lval (make_label is_global name vio, make_var is_global name) + +(** Create a fresh non-global named variable. *) +let make_fresh (name : string) : tau = + make_var false name + +(** The default type for constants. *) +let bottom () : tau = + make_var false "bottom" + +(** Unify the result of a function with its return value. *) +let return (t : tau) (t' : tau) = + add_toplev_constraint (Leq (t', (0, Sub), t)) + +(***********************************************************************) +(* *) +(* Query/Extract Solutions *) +(* *) +(***********************************************************************) + +let make_summary = leq_label + +let path_signature k l l' b : int list = + let ksig = + match k with + Positive -> 1 + | Negative -> 2 + | _ -> 3 + in + [ksig; + get_label_stamp l; + get_label_stamp l'; + if b then 1 else 0] + +let make_path (k, l, l', b) = + let psig = path_signature k l l' b in + if PH.mem path_hash psig then () + else + let new_path = {kind = k; head = l; tail = l'; reached_global = b} + and li, li' = find l, find l' in + PH.add path_hash psig new_path; + Q.add new_path path_worklist; + begin + match k with + Positive -> + li.p_upath <- P.add new_path li.p_upath; + li'.p_lpath <- P.add new_path li'.p_lpath + | Negative -> + li.n_upath <- P.add new_path li.n_upath; + li'.n_lpath <- P.add new_path li'.n_lpath + | _ -> + li.m_upath <- P.add new_path li.m_upath; + li'.m_lpath <- P.add new_path li'.m_lpath + end; + if !debug then + begin + print_string "Discovered path : "; + print_path new_path; + print_newline () + end + +let backwards_tabulate (l : label) : unit = + let rec loop () = + let rule1 p = + if !debug then print_endline "rule1"; + B.iter + (fun lb -> + make_path (Match, lb.info, p.tail, + p.reached_global || is_global_label p.head)) + (find p.head).m_lbounds + and rule2 p = + if !debug then print_endline "rule2"; + B.iter + (fun lb -> + make_path (Negative, lb.info, p.tail, + p.reached_global || is_global_label p.head)) + (find p.head).n_lbounds + and rule2m p = + if !debug then print_endline "rule2m"; + B.iter + (fun lb -> + make_path (Match, lb.info, p.tail, + p.reached_global || is_global_label p.head)) + (find p.head).n_lbounds + and rule3 p = + if !debug then print_endline "rule3"; + B.iter + (fun lb -> + make_path (Positive, lb.info, p.tail, + p.reached_global || is_global_label p.head)) + (find p.head).p_lbounds + and rule4 p = + if !debug then print_endline "rule4"; + B.iter + (fun lb -> + make_path(Negative, lb.info, p.tail, + p.reached_global || is_global_label p.head)) + (find p.head).m_lbounds + and rule5 p = + if !debug then print_endline "rule5"; + B.iter + (fun lb -> + make_path (Positive, lb.info, p.tail, + p.reached_global || is_global_label p.head)) + (find p.head).m_lbounds + and rule6 p = + if !debug then print_endline "rule6"; + B.iter + (fun lb -> + if is_seeded_label lb.info then () + else + begin + (find lb.info).l_seeded <- true; (* set seeded *) + make_path (Seed, lb.info, lb.info, + is_global_label lb.info) + end) + (find p.head).p_lbounds + and rule7 p = + if !debug then print_endline "rule7"; + if not (is_ret_label p.tail && is_param_label p.head) then () + else + B.iter + (fun lb -> + B.iter + (fun ub -> + if lb.index = ub.index then + begin + if !debug then + Printf.printf "New summary : %s %s\n" + (string_of_label lb.info) + (string_of_label ub.info); + make_summary (lb.info, (0, Sub), ub.info); + (* rules 1, 4, and 5 *) + P.iter + (fun ubp -> (* rule 1 *) + make_path (Match, lb.info, ubp.tail, + ubp.reached_global)) + (find ub.info).m_upath; + P.iter + (fun ubp -> (* rule 4 *) + make_path (Negative, lb.info, ubp.tail, + ubp.reached_global)) + (find ub.info).n_upath; + P.iter + (fun ubp -> (* rule 5 *) + make_path (Positive, lb.info, ubp.tail, + ubp.reached_global)) + (find ub.info).p_upath + end) + (find p.tail).p_ubounds) + (find p.head).n_lbounds + in + let matched_backward_rules p = + rule1 p; + if p.reached_global then rule2m p else rule2 p; + rule3 p; + rule6 p; + rule7 p + and negative_backward_rules p = + rule2 p; + rule3 p; + rule4 p; + rule6 p; + rule7 p + and positive_backward_rules p = + rule3 p; + rule5 p; + rule6 p; + rule7 p + in (* loop *) + if Q.is_empty path_worklist then () + else + let p = Q.take path_worklist in + if !debug then + begin + print_string "Processing path: "; + print_path p; + print_newline () + end; + begin + match p.kind with + Positive -> + if is_global_label p.tail then matched_backward_rules p + else positive_backward_rules p + | Negative -> negative_backward_rules p + | _ -> matched_backward_rules p + end; + loop () + in (* backwards_tabulate *) + if !debug then + begin + Printf.printf "Tabulating for %s..." (string_of_label l); + if is_global_label l then print_string "(global)"; + print_newline () + end; + make_path (Seed, l, l, is_global_label l); + loop () + +let collect_ptsets (l : label) : constantset = (* todo -- cache aliases *) + let li = find l + and collect init s = + P.fold (fun x a -> C.union a (find x.head).aliases) s init + in + backwards_tabulate l; + collect (collect (collect li.aliases li.m_lpath) li.n_lpath) li.p_lpath + +let extract_ptlabel (lv : lvalue) : label option = + try + match find (proj_ref lv.contents) with + Var v -> None + | Ref r -> Some r.rl; + | _ -> raise WellFormed + with NoContents -> None + +let points_to_aux (t : tau) : constant list = + try + match find (proj_ref t) with + Var v -> [] + | Ref r -> C.elements (collect_ptsets r.rl) + | _ -> raise WellFormed + with NoContents -> [] + +let points_to_names (lv : lvalue) : string list = + List.map (fun (_, str, _) -> str) (points_to_aux lv.contents) + +let points_to (lv : lvalue) : Cil.varinfo list = + let rec get_vinfos l : Cil.varinfo list = match l with + | (_, _, h) :: t -> h :: get_vinfos t + | [] -> [] + in + get_vinfos (points_to_aux lv.contents) + +let epoints_to (t : tau) : Cil.varinfo list = + let rec get_vinfos l : Cil.varinfo list = match l with + | (_, _, h) :: t -> h :: get_vinfos t + | [] -> [] + in + get_vinfos (points_to_aux t) + +let smart_alias_query (l : label) (l' : label) : bool = + (* Set of dead configurations *) + let dead_configs : config_map = CH.create 16 in + (* the set of discovered configurations *) + let discovered : config_map = CH.create 16 in + let rec filter_match (i : int) = + B.filter (fun (b : lblinfo bound) -> i = b.index) + in + let rec simulate c l l' = + let config = (c, get_label_stamp l, get_label_stamp l') in + if U.equal (l, l') then + begin + if !debug then + Printf.printf + "%s and %s are aliased\n" + (string_of_label l) + (string_of_label l'); + raise APFound + end + else if CH.mem discovered config then () + else + begin + if !debug_aliases then + Printf.printf + "Exploring configuration %s\n" + (string_of_configuration config); + CH.add discovered config (); + B.iter + (fun lb -> simulate c lb.info l') + (get_bounds Sub false l); (* epsilon closure of l *) + B.iter + (fun lb -> simulate c l lb.info) + (get_bounds Sub false l'); (* epsilon closure of l' *) + B.iter + (fun lb -> + let matching = + filter_match lb.index (get_bounds Pos false l') + in + B.iter + (fun b -> simulate Closed lb.info b.info) + matching; + if is_global_label l' then (* positive self-loops on l' *) + simulate Closed lb.info l') + (get_bounds Pos false l); (* positive transitions on l *) + if is_global_label l then + B.iter + (fun lb -> simulate Closed l lb.info) + (get_bounds Pos false l'); (* positive self-loops on l *) + begin + match c with (* negative transitions on l, only if Open *) + Open -> + B.iter + (fun lb -> + let matching = + filter_match lb.index (get_bounds Neg false l') + in + B.iter + (fun b -> simulate Open lb.info b.info) + matching ; + if is_global_label l' then (* neg self-loops on l' *) + simulate Open lb.info l') + (get_bounds Neg false l); + if is_global_label l then + B.iter + (fun lb -> simulate Open l lb.info) + (get_bounds Neg false l') (* negative self-loops on l *) + | _ -> () + end; + (* if we got this far, then the configuration was not used *) + CH.add dead_configs config (); + end + in + try + begin + if H.mem cached_aliases (get_label_stamp l, get_label_stamp l') then + true + else + begin + simulate Open l l'; + if !debug then + Printf.printf + "%s and %s are NOT aliased\n" + (string_of_label l) + (string_of_label l'); + false + end + end + with APFound -> + CH.iter + (fun config -> fun _ -> + if not (CH.mem dead_configs config) then + H.add + cached_aliases + (get_label_stamp l, get_label_stamp l') + ()) + discovered; + true + +(** todo : uses naive alias query for now *) +let may_alias (t1 : tau) (t2 : tau) : bool = + try + let l1 = + match find (proj_ref t1) with + Ref r -> r.rl + | Var v -> raise NoContents + | _ -> raise WellFormed + and l2 = + match find (proj_ref t2) with + Ref r -> r.rl + | Var v -> raise NoContents + | _ -> raise WellFormed + in + not (C.is_empty (C.inter (collect_ptsets l1) (collect_ptsets l2))) + with NoContents -> false + +let alias_query (b : bool) (lvl : lvalue list) : int * int = + let naive_count = ref 0 in + let smart_count = ref 0 in + let lbls = List.map extract_ptlabel lvl in (* label option list *) + let ptsets = + List.map + (function + Some l -> collect_ptsets l + | None -> C.empty) + lbls in + let record_alias s lo s' lo' = + match lo, lo' with + Some l, Some l' -> + if !debug_aliases then + Printf.printf + "Checking whether %s and %s are aliased...\n" + (string_of_label l) + (string_of_label l'); + if C.is_empty (C.inter s s') then () + else + begin + incr naive_count; + if !smart_aliases && smart_alias_query l l' then + incr smart_count + end + | _ -> () + in + let rec check_alias sets labels = + match sets,labels with + s :: st, l :: lt -> + List.iter2 (record_alias s l) ptsets lbls; + check_alias st lt + | [], [] -> () + | _ -> die "check_alias" + in + check_alias ptsets lbls; + (!naive_count, !smart_count) + +let alias_frequency (lvl : (lvalue * bool) list) : int * int = + let extract_lbl (lv, b : lvalue * bool) = (lv.l, b) in + let naive_count = ref 0 in + let smart_count = ref 0 in + let lbls = List.map extract_lbl lvl in + let ptsets = + List.map + (fun (lbl, b) -> + if b then (find lbl).loc (* symbol access *) + else collect_ptsets lbl) + lbls in + let record_alias s (l, b) s' (l', b') = + if !debug_aliases then + Printf.printf + "Checking whether %s and %s are aliased...\n" + (string_of_label l) + (string_of_label l'); + if C.is_empty (C.inter s s') then () + else + begin + if !debug_aliases then + Printf.printf + "%s and %s are aliased naively...\n" + (string_of_label l) + (string_of_label l'); + incr naive_count; + if !smart_aliases then + if b || b' || smart_alias_query l l' then incr smart_count + else + Printf.printf + "%s and %s are not aliased by smart queries...\n" + (string_of_label l) + (string_of_label l'); + end + in + let rec check_alias sets labels = + match sets, labels with + s :: st, l :: lt -> + List.iter2 (record_alias s l) ptsets lbls; + check_alias st lt + | [], [] -> () + | _ -> die "check_alias" + in + check_alias ptsets lbls; + (!naive_count, !smart_count) + + +(** an interface for extracting abstract locations from this analysis *) + +type absloc = label + +let absloc_of_lvalue (l : lvalue) : absloc = l.l +let absloc_eq (a1, a2) = smart_alias_query a1 a2 +let absloc_print_name = ref true +let d_absloc () (p : absloc) = + let a = find p in + if !absloc_print_name then Pretty.dprintf "%s" a.l_name + else Pretty.dprintf "%d" a.l_stamp + +let phonyAddrOf (lv : lvalue) : lvalue = + make_lval (fresh_label true, address lv) + +(* transitive closure of points to, starting from l *) +let rec tauPointsTo (l : tau) : absloc list = + match find l with + Var _ -> [] + | Ref r -> r.rl :: tauPointsTo r.points_to + | _ -> [] + +let rec absloc_points_to (l : lvalue) : absloc list = + tauPointsTo l.contents + + +(** The following definitions are only introduced for the + compatability with Olf. *) + +exception UnknownLocation + +let finished_constraints () = () +let apply_undefined (_ : tau list) = (fresh_var true, 0) +let assign_undefined (_ : lvalue) = () + +let absloc_epoints_to = tauPointsTo diff --git a/cil/src/ext/pta/golf.mli b/cil/src/ext/pta/golf.mli new file mode 100644 index 0000000..569855c --- /dev/null +++ b/cil/src/ext/pta/golf.mli @@ -0,0 +1,83 @@ +(* + * + * Copyright (c) 2001-2002, + * John Kodumal + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +type lvalue +type tau +type absloc + +(* only for compatability with Olf *) +exception UnknownLocation + +val debug : bool ref +val debug_constraints : bool ref +val debug_aliases : bool ref +val smart_aliases : bool ref +val finished_constraints : unit -> unit (* only for compatability with Olf *) +val print_constraints : bool ref +val no_flow : bool ref +val no_sub : bool ref +val analyze_mono : bool ref +val solve_constraints : unit -> unit +val rvalue : lvalue -> tau +val deref : tau -> lvalue +val join : tau -> tau -> tau +val join_inits : tau list -> tau +val address : lvalue -> tau +val instantiate : lvalue -> int -> lvalue +val assign : lvalue -> tau -> unit +val assign_ret : int -> lvalue -> tau -> unit +val apply : tau -> tau list -> (tau * int) +val apply_undefined : tau list -> (tau * int) (* only for compatability with Olf *) +val assign_undefined : lvalue -> unit (* only for compatability with Olf *) +val make_function : string -> lvalue list -> tau -> tau +val make_lvalue : bool -> string -> (Cil.varinfo option) -> lvalue +val bottom : unit -> tau +val return : tau -> tau -> unit +val make_fresh : string -> tau +val points_to_names : lvalue -> string list +val points_to : lvalue -> Cil.varinfo list +val epoints_to : tau -> Cil.varinfo list +val string_of_lvalue : lvalue -> string +val global_lvalue : lvalue -> bool +val alias_query : bool -> lvalue list -> int * int +val alias_frequency : (lvalue * bool) list -> int * int + +val may_alias : tau -> tau -> bool + +val absloc_points_to : lvalue -> absloc list +val absloc_epoints_to : tau -> absloc list +val absloc_of_lvalue : lvalue -> absloc +val absloc_eq : (absloc * absloc) -> bool +val d_absloc : unit -> absloc -> Pretty.doc +val phonyAddrOf : lvalue -> lvalue diff --git a/cil/src/ext/pta/olf.ml b/cil/src/ext/pta/olf.ml new file mode 100644 index 0000000..0d77002 --- /dev/null +++ b/cil/src/ext/pta/olf.ml @@ -0,0 +1,1108 @@ +(* + * + * Copyright (c) 2001-2002, + * John Kodumal + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(***********************************************************************) +(* *) +(* Exceptions *) +(* *) +(***********************************************************************) + +exception Inconsistent (* raised if constraint system is inconsistent *) +exception WellFormed (* raised if types are not well-formed *) +exception NoContents +exception APFound (* raised if an alias pair is found, a control + flow exception *) +exception ReachedTop (* raised if top (from an undefined function) + flows to a c_absloc during the flow step *) +exception UnknownLocation + +let solve_constraints () = () (* only for compatability with Golf *) + +open Cil + +module U = Uref +module S = Setp +module H = Hashtbl +module Q = Queue + +(** Generic bounds *) +type 'a bound = {info : 'a U.uref} + +module Bound = +struct + type 'a t = 'a bound + let compare (x : 'a t) (y : 'a t) = + Pervasives.compare (U.deref x.info) (U.deref y.info) +end + +module B = S.Make (Bound) + +type 'a boundset = 'a B.t + +(** Abslocs, which identify elements in points-to sets *) +(** jk : I'd prefer to make this an 'a absloc and specialize it to + varinfo for use with the Cil frontend, but for now, this will do *) +type absloc = int * string * Cil.varinfo option + +module Absloc = +struct + type t = absloc + let compare (xid, _, _) (yid, _, _) = xid - yid +end + +module C = Set.Make (Absloc) + +(** Sets of abslocs. Set union is used when two c_abslocs containing + absloc sets are unified *) +type abslocset = C.t + +let d_absloc () (a: absloc) : Pretty.doc = + let i,s,_ = a in + Pretty.dprintf "<%d, %s>" i s + +type c_abslocinfo = { + mutable l_name: string; (** name of the location *) + loc : absloc; + l_stamp : int; + mutable l_top : bool; + mutable aliases : abslocset; + mutable lbounds : c_abslocinfo boundset; + mutable ubounds : c_abslocinfo boundset; + mutable flow_computed : bool +} +and c_absloc = c_abslocinfo U.uref + +(** The type of lvalues. *) +type lvalue = { + l: c_absloc; + contents: tau +} +and vinfo = { + v_stamp : int; + v_name : string; + mutable v_top : bool; + mutable v_lbounds : tinfo boundset; + mutable v_ubounds : tinfo boundset +} +and rinfo = { + r_stamp : int; + rl : c_absloc; + points_to : tau +} +and finfo = { + f_stamp : int; + fl : c_absloc; + ret : tau; + mutable args : tau list +} +and pinfo = { + p_stamp : int; + ptr : tau; + lam : tau +} +and tinfo = + Var of vinfo + | Ref of rinfo + | Fun of finfo + | Pair of pinfo +and tau = tinfo U.uref + +type tconstraint = + Unification of tau * tau + | Leq of tau * tau + +(** Association lists, used for printing recursive types. The first + element is a type that has been visited. The second element is the + string representation of that type (so far). If the string option is + set, then this type occurs within itself, and is associated with the + recursive var name stored in the option. When walking a type, add it + to an association list. + + Example: suppose we have the constraint 'a = ref('a). The type is + unified via cyclic unification, and would loop infinitely if we + attempted to print it. What we want to do is print the type u + rv. ref(rv). This is accomplished in the following manner: + + -- ref('a) is visited. It is not in the association list, so it is + added and the string "ref(" is stored in the second element. We + recurse to print the first argument of the constructor. + + -- In the recursive call, we see that 'a (or ref('a)) is already + in the association list, so the type is recursive. We check the + string option, which is None, meaning that this is the first + recurrence of the type. We create a new recursive variable, rv and + set the string option to 'rv. Next, we prepend u rv. to the string + representation we have seen before, "ref(", and return "rv" as the + string representation of this type. + + -- The string so far is "u rv.ref(". The recursive call returns, + and we complete the type by printing the result of the call, "rv", + and ")" + + In a type where the recursive variable appears twice, e.g. 'a = + pair('a,'a), the second time we hit 'a, the string option will be + set, so we know to reuse the same recursive variable name. +*) +type association = tau * string ref * string option ref + +(** The current state of the solver engine either adding more + constraints, or finished adding constraints and querying graph *) +type state = + AddingConstraints + | FinishedConstraints + +(***********************************************************************) +(* *) +(* Global Variables *) +(* *) +(***********************************************************************) + +(** A count of the constraints introduced from the AST. Used for + debugging. *) +let toplev_count = ref 0 + +let solver_state : state ref = ref AddingConstraints + +(** Print the instantiations constraints. *) +let print_constraints : bool ref = ref false + +(** If true, print all constraints (including induced) and show + additional debug output. *) +let debug = ref false + +(** Just debug all the constraints (including induced) *) +let debug_constraints = ref false + +(** Debug the flow step *) +let debug_flow_step = ref false + +(** Compatibility with GOLF *) +let debug_aliases = ref false +let smart_aliases = ref false +let no_flow = ref false +let analyze_mono = ref false + +(** If true, disable subtyping (unification at all levels) *) +let no_sub = ref false + +(** A list of equality constraints. *) +let eq_worklist : tconstraint Q.t = Q.create () + +(** A list of leq constraints. *) +let leq_worklist : tconstraint Q.t = Q.create () + +(** A hashtable containing stamp pairs of c_abslocs that must be aliased. *) +let cached_aliases : (int * int, unit) H.t = H.create 64 + +(** A hashtable mapping pairs of tau's to their join node. *) +let join_cache : (int * int, tau) H.t = H.create 64 + +(** *) +let label_prefix = "l_" + + +(***********************************************************************) +(* *) +(* Utility Functions *) +(* *) +(***********************************************************************) + +let starts_with s p = + let n = String.length p in + if String.length s < n then false + else String.sub s 0 n = p + + +let die s = + Printf.printf "*******\nAssertion failed: %s\n*******\n" s; + assert false + +let insist b s = + if not b then die s else () + + +let can_add_constraints () = + !solver_state = AddingConstraints + +let can_query_graph () = + !solver_state = FinishedConstraints + +let finished_constraints () = + insist (!solver_state = AddingConstraints) "inconsistent states"; + solver_state := FinishedConstraints + +let find = U.deref + +(** return the prefix of the list up to and including the first + element satisfying p. if no element satisfies p, return the empty + list *) +let rec keep_until p l = + match l with + [] -> [] + | x :: xs -> if p x then [x] else x :: keep_until p xs + + +(** Generate a unique integer. *) +let fresh_index : (unit -> int) = + let counter = ref 0 in + fun () -> + incr counter; + !counter + +let fresh_stamp : (unit -> int) = + let stamp = ref 0 in + fun () -> + incr stamp; + !stamp + +(** Return a unique integer representation of a tau *) +let get_stamp (t : tau) : int = + match find t with + Var v -> v.v_stamp + | Ref r -> r.r_stamp + | Pair p -> p.p_stamp + | Fun f -> f.f_stamp + +(** Consistency checks for inferred types *) +let pair_or_var (t : tau) = + match find t with + Pair _ -> true + | Var _ -> true + | _ -> false + +let ref_or_var (t : tau) = + match find t with + Ref _ -> true + | Var _ -> true + | _ -> false + +let fun_or_var (t : tau) = + match find t with + Fun _ -> true + | Var _ -> true + | _ -> false + + +(** Apply [f] structurally down [t]. Guaranteed to terminate, even if [t] + is recursive *) +let iter_tau f t = + let visited : (int, tau) H.t = H.create 4 in + let rec iter_tau' t = + if H.mem visited (get_stamp t) then () else + begin + f t; + H.add visited (get_stamp t) t; + match find t with + Pair p -> + iter_tau' p.ptr; + iter_tau' p.lam + | Fun f -> + List.iter iter_tau' f.args; + iter_tau' f.ret; + | Ref r -> iter_tau' r.points_to + | _ -> () + end + in + iter_tau' t + +let equal_absloc = function + (i, _, _), (i', _, _) -> i = i' + +let equal_c_absloc l l' = + (find l).l_stamp = (find l').l_stamp + +let equal_tau (t : tau) (t' : tau) = + get_stamp t = get_stamp t' + +let top_c_absloc l = + (find l).l_top + +let get_flow_computed l = + (find l).flow_computed + +let set_flow_computed l = + (find l).flow_computed <- true + +let rec top_tau (t : tau) = + match find t with + Pair p -> top_tau p.ptr || top_tau p.lam + | Ref r -> top_c_absloc r.rl + | Fun f -> top_c_absloc f.fl + | Var v -> v.v_top + +let get_c_absloc_stamp (l : c_absloc) : int = + (find l).l_stamp + +let set_top_c_absloc (l : c_absloc) (b: bool) : unit = + (find l).l_top <- b + +let get_aliases (l : c_absloc) = + if top_c_absloc l then raise ReachedTop + else (find l).aliases + +(***********************************************************************) +(* *) +(* Printing Functions *) +(* *) +(***********************************************************************) + +(** Convert a c_absloc to a string, short representation *) +let string_of_c_absloc (l : c_absloc) : string = + "\"" ^ + (find l).l_name ^ + if top_c_absloc l then "(top)" else "" ^ + "\"" + +(** Return true if the element [e] is present in the association list, + according to uref equality *) +let rec assoc_list_mem (e : tau) (l : association list) = + match l with + [] -> None + | (h, s, so) :: t -> + if U.equal (h, e) then Some (s, so) + else assoc_list_mem e t + +(** Given a tau, create a unique recursive variable name. This should + always return the same name for a given tau *) +let fresh_recvar_name (t : tau) : string = + match find t with + Pair p -> "rvp" ^ string_of_int p.p_stamp + | Ref r -> "rvr" ^ string_of_int r.r_stamp + | Fun f -> "rvf" ^ string_of_int f.f_stamp + | _ -> die "fresh_recvar_name" + + +(** Return a string representation of a tau, using association lists. *) +let string_of_tau (t : tau) : string = + let tau_map : association list ref = ref [] in + let rec string_of_tau' t = + match assoc_list_mem t !tau_map with + Some (s, so) -> (* recursive type. see if a var name has been set *) + begin + match !so with + None -> + let rv = fresh_recvar_name t in + s := "u " ^ rv ^ "." ^ !s; + so := Some rv; + rv + | Some rv -> rv + end + | None -> (* type's not recursive. Add it to the assoc list and cont. *) + let s = ref "" + and so : string option ref = ref None in + tau_map := (t, s, so) :: !tau_map; + begin + match find t with + Var v -> s := v.v_name + | Pair p -> + insist (ref_or_var p.ptr) "wellformed"; + insist (fun_or_var p.lam) "wellformed"; + s := "{"; + s := !s ^ string_of_tau' p.ptr; + s := !s ^ ","; + s := !s ^ string_of_tau' p.lam; + s := !s ^ "}" + | Ref r -> + insist (pair_or_var r.points_to) "wellformed"; + s := "ref(|"; + s := !s ^ string_of_c_absloc r.rl; + s := !s ^ "|,"; + s := !s ^ string_of_tau' r.points_to; + s := !s ^ ")" + | Fun f -> + let rec string_of_args = function + [] -> () + | h :: [] -> + insist (pair_or_var h) "wellformed"; + s := !s ^ string_of_tau' h + | h :: t -> + insist (pair_or_var h) "wellformed"; + s := !s ^ string_of_tau' h ^ ","; + string_of_args t + in + insist (pair_or_var f.ret) "wellformed"; + s := "fun(|"; + s := !s ^ string_of_c_absloc f.fl; + s := !s ^ "|,"; + s := !s ^ "<"; + if List.length f.args > 0 then string_of_args f.args + else s := !s ^ "void"; + s := !s ^ ">,"; + s := !s ^ string_of_tau' f.ret; + s := !s ^ ")" + end; + tau_map := List.tl !tau_map; + !s + in + string_of_tau' t + +(** Convert an lvalue to a string *) +let rec string_of_lvalue (lv : lvalue) : string = + let contents = string_of_tau lv.contents + and l = string_of_c_absloc lv.l + in + insist (pair_or_var lv.contents) "inconsistency at string_of_lvalue"; + (* do a consistency check *) + Printf.sprintf "[%s]^(%s)" contents l + +(** Print a list of tau elements, comma separated *) +let rec print_tau_list (l : tau list) : unit = + let rec print_t_strings = function + [] -> () + | h :: [] -> print_endline h + | h :: t -> + print_string h; + print_string ", "; + print_t_strings t + in + print_t_strings (List.map string_of_tau l) + +let print_constraint (c : tconstraint) = + match c with + Unification (t, t') -> + let lhs = string_of_tau t in + let rhs = string_of_tau t' in + Printf.printf "%s == %s\n" lhs rhs + | Leq (t, t') -> + let lhs = string_of_tau t in + let rhs = string_of_tau t' in + Printf.printf "%s <= %s\n" lhs rhs + +(***********************************************************************) +(* *) +(* Type Operations -- these do not create any constraints *) +(* *) +(***********************************************************************) + +(** Create an lvalue with c_absloc [lbl] and tau contents [t]. *) +let make_lval (loc, t : c_absloc * tau) : lvalue = + {l = loc; contents = t} + +let make_c_absloc_int (is_top : bool) (name : string) (vio : Cil.varinfo option) : c_absloc = + let my_absloc = (fresh_index (), name, vio) in + let locc = C.add my_absloc C.empty + in + U.uref { + l_name = name; + l_top = is_top; + l_stamp = fresh_stamp (); + loc = my_absloc; + aliases = locc; + ubounds = B.empty; + lbounds = B.empty; + flow_computed = false + } + +(** Create a new c_absloc with name [name]. Also adds a fresh absloc + with name [name] to this c_absloc's aliases set. *) +let make_c_absloc (is_top : bool) (name : string) (vio : Cil.varinfo option) = + make_c_absloc_int is_top name vio + +let fresh_c_absloc (is_top : bool) : c_absloc = + let index = fresh_index () in + make_c_absloc_int is_top (label_prefix ^ string_of_int index) None + +(** Create a fresh bound (edge in the constraint graph). *) +let make_bound (a : c_absloc) : c_abslocinfo bound = + {info = a} + +let make_tau_bound (t : tau) : tinfo bound = + {info = t} + +(** Create a fresh named variable with name '[name]. *) +let make_var (is_top : bool) (name : string) : tau = + U.uref (Var {v_name = ("'" ^ name); + v_top = is_top; + v_stamp = fresh_index (); + v_lbounds = B.empty; + v_ubounds = B.empty}) + +let fresh_var (is_top : bool) : tau = + make_var is_top ("fi" ^ string_of_int (fresh_index ())) + +(** Create a fresh unnamed variable (name will be 'fi). *) +let fresh_var_i (is_top : bool) : tau = + make_var is_top ("fi" ^ string_of_int (fresh_index ())) + +(** Create a Fun constructor. *) +let make_fun (lbl, a, r : c_absloc * (tau list) * tau) : tau = + U.uref (Fun {fl = lbl; + f_stamp = fresh_index (); + args = a; + ret = r}) + +(** Create a Ref constructor. *) +let make_ref (lbl, pt : c_absloc * tau) : tau = + U.uref (Ref {rl = lbl; + r_stamp = fresh_index (); + points_to = pt}) + +(** Create a Pair constructor. *) +let make_pair (p, f : tau * tau) : tau = + U.uref (Pair {ptr = p; + p_stamp = fresh_index (); + lam = f}) + +(** Copy the toplevel constructor of [t], putting fresh variables in each + argement of the constructor. *) +let copy_toplevel (t : tau) : tau = + match find t with + Pair _ -> make_pair (fresh_var_i false, fresh_var_i false) + | Ref _ -> make_ref (fresh_c_absloc false, fresh_var_i false) + | Fun f -> + make_fun (fresh_c_absloc false, + List.map (fun _ -> fresh_var_i false) f.args, + fresh_var_i false) + | _ -> die "copy_toplevel" + +let has_same_structure (t : tau) (t' : tau) = + match find t, find t' with + Pair _, Pair _ -> true + | Ref _, Ref _ -> true + | Fun _, Fun _ -> true + | Var _, Var _ -> true + | _ -> false + +let pad_args (fi, tlr : finfo * tau list ref) : unit = + let padding = List.length fi.args - List.length !tlr + in + if padding == 0 then () + else + if padding > 0 then + for i = 1 to padding do + tlr := !tlr @ [fresh_var false] + done + else + for i = 1 to -padding do + fi.args <- fi.args @ [fresh_var false] + done + +(***********************************************************************) +(* *) +(* Constraint Generation/ Resolution *) +(* *) +(***********************************************************************) + +let set_top (b : bool) (t : tau) : unit = + let set_top_down t = + match find t with + Var v -> v.v_top <- b + | Ref r -> set_top_c_absloc r.rl b + | Fun f -> set_top_c_absloc f.fl b + | Pair p -> () + in + iter_tau set_top_down t + +let rec unify_int (t, t' : tau * tau) : unit = + if equal_tau t t' then () + else + let ti, ti' = find t, find t' in + U.unify combine (t, t'); + match ti, ti' with + Var v, Var v' -> + set_top (v.v_top || v'.v_top) t'; + merge_v_lbounds (v, v'); + merge_v_ubounds (v, v') + | Var v, _ -> + set_top (v.v_top || top_tau t') t'; + notify_vlbounds t v; + notify_vubounds t v + | _, Var v -> + set_top (v.v_top || top_tau t) t; + notify_vlbounds t' v; + notify_vubounds t' v + | Ref r, Ref r' -> unify_ref (r, r') + | Fun f, Fun f' -> unify_fun (f, f') + | Pair p, Pair p' -> unify_pair (p, p') + | _ -> raise Inconsistent +and notify_vlbounds (t : tau) (vi : vinfo) : unit = + let notify bounds = + List.iter + (fun b -> + add_constraint (Unification (b.info, copy_toplevel t)); + add_constraint (Leq (b.info, t))) + bounds + in + notify (B.elements vi.v_lbounds) +and notify_vubounds (t : tau) (vi : vinfo) : unit = + let notify bounds = + List.iter + (fun b -> + add_constraint (Unification (b.info, copy_toplevel t)); + add_constraint (Leq (t, b.info))) + bounds + in + notify (B.elements vi.v_ubounds) +and unify_ref (ri, ri' : rinfo * rinfo) : unit = + unify_c_abslocs (ri.rl, ri'.rl); + add_constraint (Unification (ri.points_to, ri'.points_to)) +and unify_fun (fi, fi' : finfo * finfo) : unit = + let rec union_args = function + _, [] -> false + | [], _ -> true + | h :: t, h' :: t' -> + add_constraint (Unification (h, h')); + union_args(t, t') + in + unify_c_abslocs (fi.fl, fi'.fl); + add_constraint (Unification (fi.ret, fi'.ret)); + if union_args (fi.args, fi'.args) then fi.args <- fi'.args +and unify_pair (pi, pi' : pinfo * pinfo) : unit = + add_constraint (Unification (pi.ptr, pi'.ptr)); + add_constraint (Unification (pi.lam, pi'.lam)) +and unify_c_abslocs (l, l' : c_absloc * c_absloc) : unit = + let pick_name (li, li' : c_abslocinfo * c_abslocinfo) = + if starts_with li.l_name label_prefix then li.l_name <- li'.l_name + else () in + let combine_c_absloc (li, li' : c_abslocinfo * c_abslocinfo) : c_abslocinfo = + pick_name (li, li'); + li.l_top <- li.l_top || li'.l_top; + li.aliases <- C.union li.aliases li'.aliases; + li.ubounds <- B.union li.ubounds li'.ubounds; + li.lbounds <- B.union li.lbounds li'.lbounds; + li + in + if !debug_constraints then + Printf.printf + "%s == %s\n" + (string_of_c_absloc l) + (string_of_c_absloc l'); + U.unify combine_c_absloc (l, l') +and merge_v_lbounds (vi, vi' : vinfo * vinfo) : unit = + vi'.v_lbounds <- B.union vi.v_lbounds vi'.v_lbounds; +and merge_v_ubounds (vi, vi' : vinfo * vinfo) : unit = + vi'.v_ubounds <- B.union vi.v_ubounds vi'.v_ubounds; +(** Pick the representative info for two tinfo's. This function + prefers the first argument when both arguments are the same + structure, but when one type is a structure and the other is a + var, it picks the structure. All other actions (e.g., updating + the info) is done in unify_int *) +and combine (ti, ti' : tinfo * tinfo) : tinfo = + match ti, ti' with + Var _, _ -> ti' + | _, _ -> ti +and leq_int (t, t') : unit = + if equal_tau t t' then () + else + let ti, ti' = find t, find t' in + match ti, ti' with + Var v, Var v' -> + v.v_ubounds <- B.add (make_tau_bound t') v.v_ubounds; + v'.v_lbounds <- B.add (make_tau_bound t) v'.v_lbounds + | Var v, _ -> + add_constraint (Unification (t, copy_toplevel t')); + add_constraint (Leq (t, t')) + | _, Var v -> + add_constraint (Unification (t', copy_toplevel t)); + add_constraint (Leq (t, t')) + | Ref r, Ref r' -> leq_ref (r, r') + | Fun f, Fun f' -> + (* TODO: check, why not do subtyping here? *) + add_constraint (Unification (t, t')) + | Pair pr, Pair pr' -> + add_constraint (Leq (pr.ptr, pr'.ptr)); + add_constraint (Leq (pr.lam, pr'.lam)) + | _ -> raise Inconsistent +and leq_ref (ri, ri') : unit = + leq_c_absloc (ri.rl, ri'.rl); + add_constraint (Unification (ri.points_to, ri'.points_to)) +and leq_c_absloc (l, l') : unit = + let li, li' = find l, find l' in + if !debug_constraints then + Printf.printf + "%s <= %s\n" + (string_of_c_absloc l) + (string_of_c_absloc l'); + if U.equal (l, l') then () + else + begin + li.ubounds <- B.add (make_bound l') li.ubounds; + li'.lbounds <- B.add (make_bound l) li'.lbounds + end +and add_constraint_int (c : tconstraint) (toplev : bool) = + if !debug_constraints && toplev then + begin + Printf.printf "%d:>" !toplev_count; + print_constraint c; + incr toplev_count + end + else + if !debug_constraints then print_constraint c else (); + insist (can_add_constraints ()) + "can't add constraints after compute_results is called"; + begin + match c with + Unification _ -> Q.add c eq_worklist + | Leq _ -> Q.add c leq_worklist + end; + solve_constraints () (* solve online *) +and add_constraint (c : tconstraint) = + add_constraint_int c false +and add_toplev_constraint (c : tconstraint) = + if !print_constraints && not !debug_constraints then + begin + Printf.printf "%d:>" !toplev_count; + incr toplev_count; + print_constraint c + end + else (); + add_constraint_int c true +and fetch_constraint () : tconstraint option = + try Some (Q.take eq_worklist) + with Q.Empty -> + begin + try Some (Q.take leq_worklist) + with Q.Empty -> None + end +(** The main solver loop. *) +and solve_constraints () : unit = + match fetch_constraint () with + None -> () + | Some c -> + begin + match c with + Unification (t, t') -> unify_int (t, t') + | Leq (t, t') -> + if !no_sub then unify_int (t, t') + else leq_int (t, t') + end; + solve_constraints () + +(***********************************************************************) +(* *) +(* Interface Functions *) +(* *) +(***********************************************************************) + +(** Return the contents of the lvalue. *) +let rvalue (lv : lvalue) : tau = + lv.contents + +(** Dereference the rvalue. If it does not have enough structure to + support the operation, then the correct structure is added via new + unification constraints. *) +let rec deref (t : tau) : lvalue = + match find t with + Pair p -> + begin + match find p.ptr with + | Var _ -> + let is_top = top_tau p.ptr in + let points_to = fresh_var is_top in + let l = fresh_c_absloc is_top in + let r = make_ref (l, points_to) + in + add_toplev_constraint (Unification (p.ptr, r)); + make_lval (l, points_to) + | Ref r -> make_lval (r.rl, r.points_to) + | _ -> raise WellFormed + end + | Var v -> + let is_top = top_tau t in + add_toplev_constraint + (Unification (t, make_pair (fresh_var is_top, fresh_var is_top))); + deref t + | _ -> raise WellFormed + + +(** Form the union of [t] and [t'], if it doesn't exist already. *) +let join (t : tau) (t' : tau) : tau = + let s, s' = get_stamp t, get_stamp t' in + try H.find join_cache (s, s') + with Not_found -> + let t'' = fresh_var false in + add_toplev_constraint (Leq (t, t'')); + add_toplev_constraint (Leq (t', t'')); + H.add join_cache (s, s') t''; + t'' + +(** Form the union of a list [tl], expected to be the initializers of some + structure or array type. *) +let join_inits (tl : tau list) : tau = + let t' = fresh_var false in + List.iter (function t -> add_toplev_constraint (Leq (t, t'))) tl; + t' + +(** Take the address of an lvalue. Does not add constraints. *) +let address (lv : lvalue) : tau = + make_pair (make_ref (lv.l, lv.contents), fresh_var false ) + +(** No instantiation in this analysis *) +let instantiate (lv : lvalue) (i : int) : lvalue = + lv + +(** Constraint generated from assigning [t] to [lv]. *) +let assign (lv : lvalue) (t : tau) : unit = + add_toplev_constraint (Leq (t, lv.contents)) + +let assign_ret (i : int) (lv : lvalue) (t : tau) : unit = + add_toplev_constraint (Leq (t, lv.contents)) + +(** Project out the first (ref) component or a pair. If the argument + [t] has no discovered structure, raise NoContents. *) +let proj_ref (t : tau) : tau = + match find t with + Pair p -> p.ptr + | Var v -> raise NoContents + | _ -> raise WellFormed + +(* Project out the second (fun) component of a pair. If the argument + [t] has no discovered structure, create it on the fly by adding + constraints. *) +let proj_fun (t : tau) : tau = + match find t with + Pair p -> p.lam + | Var v -> + let p, f = fresh_var false, fresh_var false in + add_toplev_constraint (Unification (t, make_pair (p, f))); + f + | _ -> raise WellFormed + +let get_args (t : tau) : tau list = + match find t with + Fun f -> f.args + | _ -> raise WellFormed + +let get_finfo (t : tau) : finfo = + match find t with + Fun f -> f + | _ -> raise WellFormed + +(** Function type [t] is applied to the arguments [actuals]. Unifies + the actuals with the formals of [t]. If no functions have been + discovered for [t] yet, create a fresh one and unify it with + t. The result is the return value of the function plus the index + of this application site. + + For this analysis, the application site is always 0 *) +let apply (t : tau) (al : tau list) : (tau * int) = + let f = proj_fun t in + let actuals = ref al in + let fi, ret = + match find f with + Fun fi -> fi, fi.ret + | Var v -> + let new_l, new_ret, new_args = + fresh_c_absloc false, + fresh_var false, + List.map (function _ -> fresh_var false) !actuals + in + let new_fun = make_fun (new_l, new_args, new_ret) in + add_toplev_constraint (Unification (new_fun, f)); + (get_finfo new_fun, new_ret) + | _ -> raise WellFormed + in + pad_args (fi, actuals); + List.iter2 + (fun actual -> fun formal -> + add_toplev_constraint (Leq (actual, formal))) + !actuals fi.args; + (ret, 0) + +let make_undefined_lvalue () = + make_lval (make_c_absloc false "undefined" None, + make_var true "undefined") + +let make_undefined_rvalue () = + make_var true "undefined" + +let assign_undefined (lv : lvalue) : unit = + assign lv (make_undefined_rvalue ()) + +let apply_undefined (al : tau list) : (tau * int) = + List.iter + (fun actual -> assign (make_undefined_lvalue ()) actual) + al; + (fresh_var true, 0) + +(** Create a new function type with name [name], list of formal + arguments [formals], and return value [ret]. Adds no constraints. *) +let make_function (name : string) (formals : lvalue list) (ret : tau) : tau = + let f = make_fun (make_c_absloc false name None, + List.map (fun x -> rvalue x) formals, + ret) + in + make_pair (fresh_var false, f) + +(** Create an lvalue. *) +let make_lvalue (b : bool ) (name : string) (vio : Cil.varinfo option) = + make_lval (make_c_absloc false name vio, + make_var false name) + +(** Create a fresh named variable. *) +let make_fresh (name : string) : tau = + make_var false name + +(** The default type for abslocs. *) +let bottom () : tau = + make_var false "bottom" + +(** Unify the result of a function with its return value. *) +let return (t : tau) (t' : tau) = + add_toplev_constraint (Leq (t', t)) + +(***********************************************************************) +(* *) +(* Query/Extract Solutions *) +(* *) +(***********************************************************************) + +module IntHash = Hashtbl.Make (struct + type t = int + let equal x y = x = y + let hash x = x + end) + +(** todo : reached_top !! *) +let collect_ptset_fast (l : c_absloc) : abslocset = + let onpath : unit IntHash.t = IntHash.create 101 in + let path : c_absloc list ref = ref [] in + let compute_path (i : int) = + keep_until (fun l -> i = get_c_absloc_stamp l) !path in + let collapse_cycle (cycle : c_absloc list) = + match cycle with + l :: ls -> + List.iter (fun l' -> unify_c_abslocs (l, l')) ls; + C.empty + | [] -> die "collapse cycle" in + let rec flow_step (l : c_absloc) : abslocset = + let stamp = get_c_absloc_stamp l in + if IntHash.mem onpath stamp then (* already seen *) + collapse_cycle (compute_path stamp) + else + let li = find l in + IntHash.add onpath stamp (); + path := l :: !path; + B.iter + (fun lb -> li.aliases <- C.union li.aliases (flow_step lb.info)) + li.lbounds; + path := List.tl !path; + IntHash.remove onpath stamp; + li.aliases + in + insist (can_query_graph ()) "collect_ptset_fast can't query graph"; + if get_flow_computed l then get_aliases l + else + begin + set_flow_computed l; + flow_step l + end + +(** this is a quadratic flow step. keep it for debugging the fast + version above. *) +let collect_ptset_slow (l : c_absloc) : abslocset = + let onpath : unit IntHash.t = IntHash.create 101 in + let rec flow_step (l : c_absloc) : abslocset = + if top_c_absloc l then raise ReachedTop + else + let stamp = get_c_absloc_stamp l in + if IntHash.mem onpath stamp then C.empty + else + let li = find l in + IntHash.add onpath stamp (); + B.iter + (fun lb -> li.aliases <- C.union li.aliases (flow_step lb.info)) + li.lbounds; + li.aliases + in + insist (can_query_graph ()) "collect_ptset_slow can't query graph"; + if get_flow_computed l then get_aliases l + else + begin + set_flow_computed l; + flow_step l + end + +let collect_ptset = + collect_ptset_slow + (* if !debug_flow_step then collect_ptset_slow + else collect_ptset_fast *) + +let may_alias (t1 : tau) (t2 : tau) : bool = + let get_l (t : tau) : c_absloc = + match find (proj_ref t) with + Ref r -> r.rl + | Var v -> raise NoContents + | _ -> raise WellFormed + in + try + let l1 = get_l t1 + and l2 = get_l t2 in + equal_c_absloc l1 l2 || + not (C.is_empty (C.inter (collect_ptset l1) (collect_ptset l2))) + with + NoContents -> false + | ReachedTop -> raise UnknownLocation + +let points_to_aux (t : tau) : absloc list = + try + match find (proj_ref t) with + Var v -> [] + | Ref r -> C.elements (collect_ptset r.rl) + | _ -> raise WellFormed + with + NoContents -> [] + | ReachedTop -> raise UnknownLocation + +let points_to (lv : lvalue) : Cil.varinfo list = + let rec get_vinfos l : Cil.varinfo list = + match l with + [] -> [] + | (_, _, Some h) :: t -> h :: get_vinfos t + | (_, _, None) :: t -> get_vinfos t + in + get_vinfos (points_to_aux lv.contents) + +let epoints_to (t : tau) : Cil.varinfo list = + let rec get_vinfos l : Cil.varinfo list = match l with + [] -> [] + | (_, _, Some h) :: t -> h :: get_vinfos t + | (_, _, None) :: t -> get_vinfos t + in + get_vinfos (points_to_aux t) + +let points_to_names (lv : lvalue) : string list = + List.map (fun v -> v.vname) (points_to lv) + +let absloc_points_to (lv : lvalue) : absloc list = + points_to_aux lv.contents + +let absloc_epoints_to (t : tau) : absloc list = + points_to_aux t + +let absloc_of_lvalue (lv : lvalue) : absloc = + (find lv.l).loc + +let absloc_eq = equal_absloc diff --git a/cil/src/ext/pta/olf.mli b/cil/src/ext/pta/olf.mli new file mode 100644 index 0000000..4379482 --- /dev/null +++ b/cil/src/ext/pta/olf.mli @@ -0,0 +1,80 @@ +(* + * + * Copyright (c) 2001-2002, + * John Kodumal + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +type lvalue +type tau +type absloc + +(** Raised if a pointer flows to an undefined function. + We assume that such a function can have any effect on the pointer's contents +*) +exception UnknownLocation + +val debug : bool ref +val debug_constraints : bool ref +val debug_aliases : bool ref +val smart_aliases : bool ref +val finished_constraints : unit -> unit +val print_constraints : bool ref +val no_flow : bool ref +val no_sub : bool ref +val analyze_mono : bool ref +val solve_constraints : unit -> unit (* only for compatability with Golf *) +val rvalue : lvalue -> tau +val deref : tau -> lvalue +val join : tau -> tau -> tau +val join_inits : tau list -> tau +val address : lvalue -> tau +val instantiate : lvalue -> int -> lvalue +val assign : lvalue -> tau -> unit +val assign_ret : int -> lvalue -> tau -> unit +val apply : tau -> tau list -> (tau * int) +val apply_undefined : tau list -> (tau * int) +val assign_undefined : lvalue -> unit +val make_function : string -> lvalue list -> tau -> tau +val make_lvalue : bool -> string -> (Cil.varinfo option) -> lvalue +val bottom : unit -> tau +val return : tau -> tau -> unit +val make_fresh : string -> tau +val points_to_names : lvalue -> string list +val points_to : lvalue -> Cil.varinfo list +val epoints_to : tau -> Cil.varinfo list +val string_of_lvalue : lvalue -> string +val may_alias : tau -> tau -> bool + +val absloc_points_to : lvalue -> absloc list +val absloc_epoints_to : tau -> absloc list +val absloc_of_lvalue : lvalue -> absloc +val absloc_eq : (absloc * absloc) -> bool +val d_absloc : unit -> absloc -> Pretty.doc diff --git a/cil/src/ext/pta/ptranal.ml b/cil/src/ext/pta/ptranal.ml new file mode 100644 index 0000000..c91bda8 --- /dev/null +++ b/cil/src/ext/pta/ptranal.ml @@ -0,0 +1,597 @@ +(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) + +(* + * + * Copyright (c) 2001-2002, + * John Kodumal + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +exception Bad_return +exception Bad_function + + +open Cil + +module H = Hashtbl + +module A = Olf +exception UnknownLocation = A.UnknownLocation + +type access = A.lvalue * bool + +type access_map = (lval, access) H.t + +(** a mapping from varinfo's back to fundecs *) +module VarInfoKey = +struct + type t = varinfo + let compare v1 v2 = v1.vid - v2.vid +end + +module F = Map.Make (VarInfoKey) + + +(***********************************************************************) +(* *) +(* Global Variables *) +(* *) +(***********************************************************************) + +let model_strings = ref false +let print_constraints = A.print_constraints +let debug_constraints = A.debug_constraints +let debug_aliases = A.debug_aliases +let smart_aliases = A.smart_aliases +let debug = A.debug +let analyze_mono = A.analyze_mono +let no_flow = A.no_flow +let no_sub = A.no_sub +let fun_ptrs_as_funs = ref false +let show_progress = ref false +let debug_may_aliases = ref false + +let found_undefined = ref false + +let conservative_undefineds = ref false + +let current_fundec : fundec option ref = ref None + +let fun_access_map : (fundec, access_map) H.t = H.create 64 + +(* A mapping from varinfos to fundecs *) +let fun_varinfo_map = ref F.empty + +let current_ret : A.tau option ref = ref None + +let lvalue_hash : (varinfo,A.lvalue) H.t = H.create 64 + +let expressions : (exp,A.tau) H.t = H.create 64 + +let lvalues : (lval,A.lvalue) H.t = H.create 64 + +let fresh_index : (unit -> int) = + let count = ref 0 in + fun () -> + incr count; + !count + +let alloc_names = [ + "malloc"; + "calloc"; + "realloc"; + "xmalloc"; + "__builtin_alloca"; + "alloca"; + "kmalloc" +] + +let all_globals : varinfo list ref = ref [] +let all_functions : fundec list ref = ref [] + + +(***********************************************************************) +(* *) +(* Utility Functions *) +(* *) +(***********************************************************************) + +let is_undefined_fun = function + Lval (lh, o) -> + if isFunctionType (typeOfLval (lh, o)) then + match lh with + Var v -> v.vstorage = Extern + | _ -> false + else false + | _ -> false + +let is_alloc_fun = function + Lval (lh, o) -> + if isFunctionType (typeOfLval (lh, o)) then + match lh with + Var v -> List.mem v.vname alloc_names + | _ -> false + else false + | _ -> false + +let next_alloc = function + Lval (Var v, o) -> + let name = Printf.sprintf "%s@%d" v.vname (fresh_index ()) + in + A.address (A.make_lvalue false name (Some v)) (* check *) + | _ -> raise Bad_return + +let is_effect_free_fun = function + Lval (lh, o) when isFunctionType (typeOfLval (lh, o)) -> + begin + match lh with + Var v -> + begin + try ("CHECK_" = String.sub v.vname 0 6) + with Invalid_argument _ -> false + end + | _ -> false + end + | _ -> false + + +(***********************************************************************) +(* *) +(* AST Traversal Functions *) +(* *) +(***********************************************************************) + +(* should do nothing, might need to worry about Index case *) +(* let analyzeOffset (o : offset ) : A.tau = A.bottom () *) + +let analyze_var_decl (v : varinfo ) : A.lvalue = + try H.find lvalue_hash v + with Not_found -> + let lv = A.make_lvalue false v.vname (Some v) + in + H.add lvalue_hash v lv; + lv + +let isFunPtrType (t : typ) : bool = + match t with + TPtr (t, _) -> isFunctionType t + | _ -> false + +let rec analyze_lval (lv : lval ) : A.lvalue = + let find_access (l : A.lvalue) (is_var : bool) : A.lvalue = + match !current_fundec with + None -> l + | Some f -> + let accesses = H.find fun_access_map f in + if H.mem accesses lv then l + else + begin + H.add accesses lv (l, is_var); + l + end in + let result = + match lv with + Var v, _ -> (* instantiate every syntactic occurrence of a function *) + let alv = + if isFunctionType (typeOfLval lv) then + A.instantiate (analyze_var_decl v) (fresh_index ()) + else analyze_var_decl v + in + find_access alv true + | Mem e, _ -> + (* assert (not (isFunctionType(typeOf(e))) ); *) + let alv = + if !fun_ptrs_as_funs && isFunPtrType (typeOf e) then + analyze_expr_as_lval e + else A.deref (analyze_expr e) + in + find_access alv false + in + H.replace lvalues lv result; + result +and analyze_expr_as_lval (e : exp) : A.lvalue = + match e with + Lval l -> analyze_lval l + | _ -> assert false (* todo -- other kinds of expressions? *) +and analyze_expr (e : exp ) : A.tau = + let result = + match e with + Const (CStr s) -> + if !model_strings then + A.address (A.make_lvalue + false + s + (Some (makeVarinfo false s charConstPtrType))) + else A.bottom () + | Const c -> A.bottom () + | Lval l -> A.rvalue (analyze_lval l) + | SizeOf _ -> A.bottom () + | SizeOfStr _ -> A.bottom () + | AlignOf _ -> A.bottom () + | UnOp (op, e, t) -> analyze_expr e + | BinOp (op, e, e', t) -> A.join (analyze_expr e) (analyze_expr e') + | CastE (t, e) -> analyze_expr e + | AddrOf l -> + if !fun_ptrs_as_funs && isFunctionType (typeOfLval l) then + A.rvalue (analyze_lval l) + else A.address (analyze_lval l) + | StartOf l -> A.address (analyze_lval l) + | AlignOfE _ -> A.bottom () + | SizeOfE _ -> A.bottom () + in + H.add expressions e result; + result + + +(* check *) +let rec analyze_init (i : init ) : A.tau = + match i with + SingleInit e -> analyze_expr e + | CompoundInit (t, oi) -> + A.join_inits (List.map (function (_, i) -> analyze_init i) oi) + +let analyze_instr (i : instr ) : unit = + match i with + Set (lval, rhs, l) -> + A.assign (analyze_lval lval) (analyze_expr rhs) + | Call (res, fexpr, actuals, l) -> + if not (isFunctionType (typeOf fexpr)) then + () (* todo : is this a varargs? *) + else if is_alloc_fun fexpr then + begin + if !debug then print_string "Found allocation function...\n"; + match res with + Some r -> A.assign (analyze_lval r) (next_alloc fexpr) + | None -> () + end + else if is_effect_free_fun fexpr then + List.iter (fun e -> ignore (analyze_expr e)) actuals + else (* todo : check to see if the thing is an undefined function *) + let fnres, site = + if is_undefined_fun fexpr & !conservative_undefineds then + A.apply_undefined (List.map analyze_expr actuals) + else + A.apply (analyze_expr fexpr) (List.map analyze_expr actuals) + in + begin + match res with + Some r -> + begin + A.assign_ret site (analyze_lval r) fnres; + found_undefined := true; + end + | None -> () + end + | Asm _ -> () + +let rec analyze_stmt (s : stmt ) : unit = + match s.skind with + Instr il -> List.iter analyze_instr il + | Return (eo, l) -> + begin + match eo with + Some e -> + begin + match !current_ret with + Some ret -> A.return ret (analyze_expr e) + | None -> raise Bad_return + end + | None -> () + end + | Goto (s', l) -> () (* analyze_stmt(!s') *) + | If (e, b, b', l) -> + (* ignore the expression e; expressions can't be side-effecting *) + analyze_block b; + analyze_block b' + | Switch (e, b, sl, l) -> + analyze_block b; + List.iter analyze_stmt sl +(* + | Loop (b, l, _, _) -> analyze_block b +*) + | While (_, b, _) -> analyze_block b + | DoWhile (_, b, _) -> analyze_block b + | For (bInit, _, bIter, b, _) -> + analyze_block bInit; + analyze_block bIter; + analyze_block b + | Block b -> analyze_block b + | TryFinally (b, h, _) -> + analyze_block b; + analyze_block h + | TryExcept (b, (il, _), h, _) -> + analyze_block b; + List.iter analyze_instr il; + analyze_block h + | Break l -> () + | Continue l -> () + + +and analyze_block (b : block ) : unit = + List.iter analyze_stmt b.bstmts + +let analyze_function (f : fundec ) : unit = + let oldlv = analyze_var_decl f.svar in + let ret = A.make_fresh (f.svar.vname ^ "_ret") in + let formals = List.map analyze_var_decl f.sformals in + let newf = A.make_function f.svar.vname formals ret in + if !show_progress then + Printf.printf "Analyzing function %s\n" f.svar.vname; + fun_varinfo_map := F.add f.svar f (!fun_varinfo_map); + current_fundec := Some f; + H.add fun_access_map f (H.create 8); + A.assign oldlv newf; + current_ret := Some ret; + analyze_block f.sbody + +let analyze_global (g : global ) : unit = + match g with + GVarDecl (v, l) -> () (* ignore (analyze_var_decl(v)) -- no need *) + | GVar (v, init, l) -> + all_globals := v :: !all_globals; + begin + match init.init with + Some i -> A.assign (analyze_var_decl v) (analyze_init i) + | None -> ignore (analyze_var_decl v) + end + | GFun (f, l) -> + all_functions := f :: !all_functions; + analyze_function f + | _ -> () + +let analyze_file (f : file) : unit = + iterGlobals f analyze_global + + +(***********************************************************************) +(* *) +(* High-level Query Interface *) +(* *) +(***********************************************************************) + +(* Same as analyze_expr, but no constraints. *) +let rec traverse_expr (e : exp) : A.tau = + H.find expressions e + +and traverse_expr_as_lval (e : exp) : A.lvalue = + match e with + | Lval l -> traverse_lval l + | _ -> assert false (* todo -- other kinds of expressions? *) + +and traverse_lval (lv : lval ) : A.lvalue = + H.find lvalues lv + +let may_alias (e1 : exp) (e2 : exp) : bool = + let tau1,tau2 = traverse_expr e1, traverse_expr e2 in + let result = A.may_alias tau1 tau2 in + if !debug_may_aliases then + begin + let doc1 = d_exp () e1 in + let doc2 = d_exp () e2 in + let s1 = Pretty.sprint ~width:30 doc1 in + let s2 = Pretty.sprint ~width:30 doc2 in + Printf.printf + "%s and %s may alias? %s\n" + s1 + s2 + (if result then "yes" else "no") + end; + result + +let resolve_lval (lv : lval) : varinfo list = + A.points_to (traverse_lval lv) + +let resolve_exp (e : exp) : varinfo list = + A.epoints_to (traverse_expr e) + +let resolve_funptr (e : exp) : fundec list = + let varinfos = A.epoints_to (traverse_expr e) in + List.fold_left + (fun fdecs -> fun vinf -> + try F.find vinf !fun_varinfo_map :: fdecs + with Not_found -> fdecs) + [] + varinfos + +let count_hash_elts h = + let result = ref 0 in + H.iter (fun _ -> fun _ -> incr result) lvalue_hash; + !result + +let compute_may_aliases (b : bool) : unit = + let rec compute_may_aliases_aux (exps : exp list) = + match exps with + [] -> () + | h :: t -> + ignore (List.map (may_alias h) t); + compute_may_aliases_aux t + and exprs : exp list ref = ref [] in + H.iter (fun e -> fun _ -> exprs := e :: !exprs) expressions; + compute_may_aliases_aux !exprs + + +let compute_results (show_sets : bool) : unit = + let total_pointed_to = ref 0 + and total_lvalues = H.length lvalue_hash + and counted_lvalues = ref 0 + and lval_elts : (string * (string list)) list ref = ref [] in + let print_result (name, set) = + let rec print_set s = + match s with + [] -> () + | h :: [] -> print_string h + | h :: t -> + print_string (h ^ ", "); + print_set t + and ptsize = List.length set in + total_pointed_to := !total_pointed_to + ptsize; + if ptsize > 0 then + begin + print_string (name ^ "(" ^ (string_of_int ptsize) ^ ") -> "); + print_set set; + print_newline () + end + in + (* Make the most pessimistic assumptions about globals if an + undefined function is present. Such a function can write to every + global variable *) + let hose_globals () : unit = + List.iter + (fun vd -> A.assign_undefined (analyze_var_decl vd)) + !all_globals + in + let show_progress_fn (counted : int ref) (total : int) : unit = + incr counted; + if !show_progress then + Printf.printf "Computed flow for %d of %d sets\n" !counted total + in + if !conservative_undefineds && !found_undefined then hose_globals (); + A.finished_constraints (); + if show_sets then + begin + print_endline "Computing points-to sets..."; + Hashtbl.iter + (fun vinf -> fun lv -> + show_progress_fn counted_lvalues total_lvalues; + try lval_elts := (vinf.vname, A.points_to_names lv) :: !lval_elts + with A.UnknownLocation -> ()) + lvalue_hash; + List.iter print_result !lval_elts; + Printf.printf + "Total number of things pointed to: %d\n" + !total_pointed_to + end; + if !debug_may_aliases then + begin + Printf.printf "Printing may alias relationships\n"; + compute_may_aliases true + end + +let print_types () : unit = + print_string "Printing inferred types of lvalues...\n"; + Hashtbl.iter + (fun vi -> fun lv -> + Printf.printf "%s : %s\n" vi.vname (A.string_of_lvalue lv)) + lvalue_hash + + + +(** Alias queries. For each function, gather sets of locals, formals, and + globals. Do n^2 work for each of these functions, reporting whether or not + each pair of values is aliased. Aliasing is determined by taking points-to + set intersections. +*) +let compute_aliases = compute_may_aliases + + +(***********************************************************************) +(* *) +(* Abstract Location Interface *) +(* *) +(***********************************************************************) + +type absloc = A.absloc + +let rec lvalue_of_varinfo (vi : varinfo) : A.lvalue = + H.find lvalue_hash vi + +let lvalue_of_lval = traverse_lval +let tau_of_expr = traverse_expr + +(** return an abstract location for a varinfo, resp. lval *) +let absloc_of_varinfo vi = + A.absloc_of_lvalue (lvalue_of_varinfo vi) + +let absloc_of_lval lv = + A.absloc_of_lvalue (lvalue_of_lval lv) + +let absloc_e_points_to e = + A.absloc_epoints_to (tau_of_expr e) + +let absloc_lval_aliases lv = + A.absloc_points_to (lvalue_of_lval lv) + +(* all abslocs that e transitively points to *) +let absloc_e_transitive_points_to (e : Cil.exp) : absloc list = + let rec lv_trans_ptsto (worklist : varinfo list) (acc : varinfo list) : absloc list = + match worklist with + [] -> List.map absloc_of_varinfo acc + | vi :: wklst'' -> + if List.mem vi acc then lv_trans_ptsto wklst'' acc + else + lv_trans_ptsto + (List.rev_append + (A.points_to (lvalue_of_varinfo vi)) + wklst'') + (vi :: acc) + in + lv_trans_ptsto (A.epoints_to (tau_of_expr e)) [] + +let absloc_eq a b = A.absloc_eq (a, b) + +let d_absloc: unit -> absloc -> Pretty.doc = A.d_absloc + + +let ptrAnalysis = ref false +let ptrResults = ref false +let ptrTypes = ref false + + + +(** Turn this into a CIL feature *) +let feature : featureDescr = { + fd_name = "ptranal"; + fd_enabled = ptrAnalysis; + fd_description = "alias analysis"; + fd_extraopt = [ + ("--ptr_may_aliases", + Arg.Unit (fun _ -> debug_may_aliases := true), + "Print out results of may alias queries"); + ("--ptr_unify", Arg.Unit (fun _ -> no_sub := true), + "Make the alias analysis unification-based"); + ("--ptr_model_strings", Arg.Unit (fun _ -> model_strings := true), + "Make the alias analysis model string constants"); + ("--ptr_conservative", + Arg.Unit (fun _ -> conservative_undefineds := true), + "Treat undefineds conservatively in alias analysis"); + ("--ptr_results", Arg.Unit (fun _ -> ptrResults := true), + "print the results of the alias analysis"); + ("--ptr_mono", Arg.Unit (fun _ -> analyze_mono := true), + "run alias analysis monomorphically"); + ("--ptr_types",Arg.Unit (fun _ -> ptrTypes := true), + "print inferred points-to analysis types") + ]; + fd_doit = (function (f: file) -> + analyze_file f; + compute_results !ptrResults; + if !ptrTypes then print_types ()); + fd_post_check = false (* No changes *) +} diff --git a/cil/src/ext/pta/ptranal.mli b/cil/src/ext/pta/ptranal.mli new file mode 100644 index 0000000..36eb7a5 --- /dev/null +++ b/cil/src/ext/pta/ptranal.mli @@ -0,0 +1,156 @@ +(* + * + * Copyright (c) 2001-2002, + * John Kodumal + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(***********************************************************************) +(* *) +(* Flags *) +(* *) +(***********************************************************************) + +(** Print extra debugging info *) +val debug : bool ref + +(** Debug constraints (print all constraints) *) +val debug_constraints : bool ref + +(** Debug smart alias queries *) +val debug_aliases : bool ref + +(** Debug may alias queries *) +val debug_may_aliases : bool ref + +val smart_aliases : bool ref + +(** Print out the top level constraints *) +val print_constraints : bool ref + +(** Make the analysis monomorphic *) +val analyze_mono : bool ref + +(** Disable subtyping *) +val no_sub : bool ref + +(** Make the flow step a no-op *) +val no_flow : bool ref + +(** Show the progress of the flow step *) +val show_progress : bool ref + +(** Treat undefined functions conservatively *) +val conservative_undefineds : bool ref + +(***********************************************************************) +(* *) +(* Building the Points-to Graph *) +(* *) +(***********************************************************************) + +(** Analyze a file *) +val analyze_file : Cil.file -> unit + +(** Print the type of each lvalue in the program *) +val print_types : unit -> unit + +(***********************************************************************) +(* *) +(* High-level Query Interface *) +(* *) +(***********************************************************************) + +(** If undefined functions are analyzed conservatively, any of the + high-level queries may raise this exception *) +exception UnknownLocation + +val may_alias : Cil.exp -> Cil.exp -> bool + +val resolve_lval : Cil.lval -> (Cil.varinfo list) + +val resolve_exp : Cil.exp -> (Cil.varinfo list) + +val resolve_funptr : Cil.exp -> (Cil.fundec list) + +(***********************************************************************) +(* *) +(* Low-level Query Interface *) +(* *) +(***********************************************************************) + +(** type for abstract locations *) +type absloc + +(** Give an abstract location for a varinfo *) +val absloc_of_varinfo : Cil.varinfo -> absloc + +(** Give an abstract location for an Cil lvalue *) +val absloc_of_lval : Cil.lval -> absloc + +(** may the two abstract locations be aliased? *) +val absloc_eq : absloc -> absloc -> bool + +val absloc_e_points_to : Cil.exp -> absloc list +val absloc_e_transitive_points_to : Cil.exp -> absloc list + +val absloc_lval_aliases : Cil.lval -> absloc list + +(** Print a string representing an absloc, for debugging. *) +val d_absloc : unit -> absloc -> Pretty.doc + + +(***********************************************************************) +(* *) +(* Printing results *) +(* *) +(***********************************************************************) + +(** Compute points to sets for variables. If true is passed, print the sets. *) +val compute_results : bool -> unit + +(* + +Deprecated these. -- jk + +(** Compute alias relationships. If true is passed, print all alias pairs. *) + val compute_aliases : bool -> unit + +(** Compute alias frequncy *) +val compute_alias_frequency : unit -> unit + + +*) + +val compute_aliases : bool -> unit + + +val feature: Cil.featureDescr diff --git a/cil/src/ext/pta/setp.ml b/cil/src/ext/pta/setp.ml new file mode 100644 index 0000000..a39b972 --- /dev/null +++ b/cil/src/ext/pta/setp.ml @@ -0,0 +1,342 @@ +(* + * + * Copyright (c) 2001-2002, + * John Kodumal + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id: setp.ml,v 1.3 2003-02-19 19:26:31 jkodumal Exp $ *) + +(* Sets over ordered types *) + +module type PolyOrderedType = + sig + type 'a t + val compare: 'a t -> 'a t -> int + end + +module type S = + sig + type 'a elt + type 'a t + val empty: 'a t + val is_empty: 'a t -> bool + val mem: 'a elt -> 'a t -> bool + val add: 'a elt -> 'a t -> 'a t + val singleton: 'a elt -> 'a t + val remove: 'a elt -> 'a t -> 'a t + val union: 'a t -> 'a t -> 'a t + val inter: 'a t -> 'a t -> 'a t + val diff: 'a t -> 'a t -> 'a t + val compare: 'a t -> 'a t -> int + val equal: 'a t -> 'a t -> bool + val subset: 'a t -> 'a t -> bool + val iter: ('a elt -> unit) -> 'a t -> unit + val fold: ('a elt -> 'b -> 'b) -> 'a t -> 'b -> 'b + val for_all: ('a elt -> bool) -> 'a t -> bool + val exists: ('a elt -> bool) -> 'a t -> bool + val filter: ('a elt -> bool) -> 'a t -> 'a t + val partition: ('a elt -> bool) -> 'a t -> 'a t * 'a t + val cardinal: 'a t -> int + val elements: 'a t -> 'a elt list + val min_elt: 'a t -> 'a elt + val max_elt: 'a t -> 'a elt + val choose: 'a t -> 'a elt + end + +module Make(Ord: PolyOrderedType) = + struct + type 'a elt = 'a Ord.t + type 'a t = Empty | Node of 'a t * 'a elt * 'a t * int + + (* Sets are represented by balanced binary trees (the heights of the + children differ by at most 2 *) + + let height = function + Empty -> 0 + | Node(_, _, _, h) -> h + + (* Creates a new node with left son l, value x and right son r. + l and r must be balanced and | height l - height r | <= 2. + Inline expansion of height for better speed. *) + + let create l x r = + let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1)) + + (* Same as create, but performs one step of rebalancing if necessary. + Assumes l and r balanced. + Inline expansion of create for better speed in the most frequent case + where no rebalancing is required. *) + + let bal l x r = + let hl = match l with Empty -> 0 | Node(_,_,_,h) -> h in + let hr = match r with Empty -> 0 | Node(_,_,_,h) -> h in + if hl > hr + 2 then begin + match l with + Empty -> invalid_arg "Set.bal" + | Node(ll, lv, lr, _) -> + if height ll >= height lr then + create ll lv (create lr x r) + else begin + match lr with + Empty -> invalid_arg "Set.bal" + | Node(lrl, lrv, lrr, _)-> + create (create ll lv lrl) lrv (create lrr x r) + end + end else if hr > hl + 2 then begin + match r with + Empty -> invalid_arg "Set.bal" + | Node(rl, rv, rr, _) -> + if height rr >= height rl then + create (create l x rl) rv rr + else begin + match rl with + Empty -> invalid_arg "Set.bal" + | Node(rll, rlv, rlr, _) -> + create (create l x rll) rlv (create rlr rv rr) + end + end else + Node(l, x, r, (if hl >= hr then hl + 1 else hr + 1)) + + (* Same as bal, but repeat rebalancing until the final result + is balanced. *) + + let rec join l x r = + match bal l x r with + Empty -> invalid_arg "Set.join" + | Node(l', x', r', _) as t' -> + let d = height l' - height r' in + if d < -2 || d > 2 then join l' x' r' else t' + + (* Merge two trees l and r into one. + All elements of l must precede the elements of r. + Assumes | height l - height r | <= 2. *) + + let rec merge t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> + bal l1 v1 (bal (merge r1 l2) v2 r2) + + (* Same as merge, but does not assume anything about l and r. *) + + let rec concat t1 t2 = + match (t1, t2) with + (Empty, t) -> t + | (t, Empty) -> t + | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> + join l1 v1 (join (concat r1 l2) v2 r2) + + (* Splitting *) + + let rec split x = function + Empty -> + (Empty, None, Empty) + | Node(l, v, r, _) -> + let c = Ord.compare x v in + if c = 0 then (l, Some v, r) + else if c < 0 then + let (ll, vl, rl) = split x l in (ll, vl, join rl v r) + else + let (lr, vr, rr) = split x r in (join l v lr, vr, rr) + + (* Implementation of the set operations *) + + let empty = Empty + + let is_empty = function Empty -> true | _ -> false + + let rec mem x = function + Empty -> false + | Node(l, v, r, _) -> + let c = Ord.compare x v in + c = 0 || mem x (if c < 0 then l else r) + + let rec add x = function + Empty -> Node(Empty, x, Empty, 1) + | Node(l, v, r, _) as t -> + let c = Ord.compare x v in + if c = 0 then t else + if c < 0 then bal (add x l) v r else bal l v (add x r) + + let singleton x = Node(Empty, x, Empty, 1) + + let rec remove x = function + Empty -> Empty + | Node(l, v, r, _) -> + let c = Ord.compare x v in + if c = 0 then merge l r else + if c < 0 then bal (remove x l) v r else bal l v (remove x r) + + let rec union s1 s2 = + match (s1, s2) with + (Empty, t2) -> t2 + | (t1, Empty) -> t1 + | (Node(l1, v1, r1, h1), Node(l2, v2, r2, h2)) -> + if h1 >= h2 then + if h2 = 1 then add v2 s1 else begin + let (l2, _, r2) = split v1 s2 in + join (union l1 l2) v1 (union r1 r2) + end + else + if h1 = 1 then add v1 s2 else begin + let (l1, _, r1) = split v2 s1 in + join (union l1 l2) v2 (union r1 r2) + end + + let rec inter s1 s2 = + match (s1, s2) with + (Empty, t2) -> Empty + | (t1, Empty) -> Empty + | (Node(l1, v1, r1, _), t2) -> + match split v1 t2 with + (l2, None, r2) -> + concat (inter l1 l2) (inter r1 r2) + | (l2, Some _, r2) -> + join (inter l1 l2) v1 (inter r1 r2) + + let rec diff s1 s2 = + match (s1, s2) with + (Empty, t2) -> Empty + | (t1, Empty) -> t1 + | (Node(l1, v1, r1, _), t2) -> + match split v1 t2 with + (l2, None, r2) -> + join (diff l1 l2) v1 (diff r1 r2) + | (l2, Some _, r2) -> + concat (diff l1 l2) (diff r1 r2) + + let rec compare_aux l1 l2 = + match (l1, l2) with + ([], []) -> 0 + | ([], _) -> -1 + | (_, []) -> 1 + | (Empty :: t1, Empty :: t2) -> + compare_aux t1 t2 + | (Node(Empty, v1, r1, _) :: t1, Node(Empty, v2, r2, _) :: t2) -> + let c = Ord.compare v1 v2 in + if c <> 0 then c else compare_aux (r1::t1) (r2::t2) + | (Node(l1, v1, r1, _) :: t1, t2) -> + compare_aux (l1 :: Node(Empty, v1, r1, 0) :: t1) t2 + | (t1, Node(l2, v2, r2, _) :: t2) -> + compare_aux t1 (l2 :: Node(Empty, v2, r2, 0) :: t2) + + let compare s1 s2 = + compare_aux [s1] [s2] + + let equal s1 s2 = + compare s1 s2 = 0 + + let rec subset s1 s2 = + match (s1, s2) with + Empty, _ -> + true + | _, Empty -> + false + | Node (l1, v1, r1, _), (Node (l2, v2, r2, _) as t2) -> + let c = Ord.compare v1 v2 in + if c = 0 then + subset l1 l2 && subset r1 r2 + else if c < 0 then + subset (Node (l1, v1, Empty, 0)) l2 && subset r1 t2 + else + subset (Node (Empty, v1, r1, 0)) r2 && subset l1 t2 + + let rec iter f = function + Empty -> () + | Node(l, v, r, _) -> iter f l; f v; iter f r + + let rec fold f s accu = + match s with + Empty -> accu + | Node(l, v, r, _) -> fold f l (f v (fold f r accu)) + + let rec for_all p = function + Empty -> true + | Node(l, v, r, _) -> p v && for_all p l && for_all p r + + let rec exists p = function + Empty -> false + | Node(l, v, r, _) -> p v || exists p l || exists p r + + let filter p s = + let rec filt accu = function + | Empty -> accu + | Node(l, v, r, _) -> + filt (filt (if p v then add v accu else accu) l) r in + filt Empty s + + let partition p s = + let rec part (t, f as accu) = function + | Empty -> accu + | Node(l, v, r, _) -> + part (part (if p v then (add v t, f) else (t, add v f)) l) r in + part (Empty, Empty) s + + let rec cardinal = function + Empty -> 0 + | Node(l, v, r, _) -> cardinal l + 1 + cardinal r + + let rec elements_aux accu = function + Empty -> accu + | Node(l, v, r, _) -> elements_aux (v :: elements_aux accu r) l + + let elements s = + elements_aux [] s + + let rec min_elt = function + Empty -> raise Not_found + | Node(Empty, v, r, _) -> v + | Node(l, v, r, _) -> min_elt l + + let rec max_elt = function + Empty -> raise Not_found + | Node(l, v, Empty, _) -> v + | Node(l, v, r, _) -> max_elt r + + let choose = min_elt + + end diff --git a/cil/src/ext/pta/setp.mli b/cil/src/ext/pta/setp.mli new file mode 100644 index 0000000..a3b3031 --- /dev/null +++ b/cil/src/ext/pta/setp.mli @@ -0,0 +1,180 @@ +(* + * + * Copyright (c) 2001-2002, + * John Kodumal + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +(***********************************************************************) +(* *) +(* Objective Caml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file ../LICENSE. *) +(* *) +(***********************************************************************) + +(* $Id: setp.mli,v 1.3 2003-02-19 19:26:31 jkodumal Exp $ *) + +(** Sets over ordered types. + + This module implements the set data structure, given a total ordering + function over the set elements. All operations over sets + are purely applicative (no side-effects). + The implementation uses balanced binary trees, and is therefore + reasonably efficient: insertion and membership take time + logarithmic in the size of the set, for instance. +*) + +module type PolyOrderedType = + sig + type 'a t + (** The type of the set elements. *) + val compare : 'a t -> 'a t -> int + (** A total ordering function over the set elements. + This is a two-argument function [f] such that + [f e1 e2] is zero if the elements [e1] and [e2] are equal, + [f e1 e2] is strictly negative if [e1] is smaller than [e2], + and [f e1 e2] is strictly positive if [e1] is greater than [e2]. + Example: a suitable ordering function is + the generic structural comparison function {!Pervasives.compare}. *) + end +(** Input signature of the functor {!Set.Make}. *) + +module type S = + sig + type 'a elt + (** The type of the set elements. *) + + type 'a t + (** The type of sets. *) + + val empty: 'a t + (** The empty set. *) + + val is_empty: 'a t -> bool + (** Test whether a set is empty or not. *) + + val mem: 'a elt -> 'a t -> bool + (** [mem x s] tests whether [x] belongs to the set [s]. *) + + val add: 'a elt -> 'a t -> 'a t + (** [add x s] returns a set containing all elements of [s], + plus [x]. If [x] was already in [s], [s] is returned unchanged. *) + + val singleton: 'a elt -> 'a t + (** [singleton x] returns the one-element set containing only [x]. *) + + val remove: 'a elt -> 'a t -> 'a t + (** [remove x s] returns a set containing all elements of [s], + except [x]. If [x] was not in [s], [s] is returned unchanged. *) + + val union: 'a t -> 'a t -> 'a t + (** Set union. *) + + val inter: 'a t -> 'a t -> 'a t + (** Set interseection. *) + + (** Set difference. *) + val diff: 'a t -> 'a t -> 'a t + + val compare: 'a t -> 'a t -> int + (** Total ordering between sets. Can be used as the ordering function + for doing sets of sets. *) + + val equal: 'a t -> 'a t -> bool + (** [equal s1 s2] tests whether the sets [s1] and [s2] are + equal, that is, contain equal elements. *) + + val subset: 'a t -> 'a t -> bool + (** [subset s1 s2] tests whether the set [s1] is a subset of + the set [s2]. *) + + val iter: ('a elt -> unit) -> 'a t -> unit + (** [iter f s] applies [f] in turn to all elements of [s]. + The order in which the elements of [s] are presented to [f] + is unspecified. *) + + val fold: ('a elt -> 'b -> 'b) -> 'a t -> 'b -> 'b + (** [fold f s a] computes [(f xN ... (f x2 (f x1 a))...)], + where [x1 ... xN] are the elements of [s]. + The order in which elements of [s] are presented to [f] is + unspecified. *) + + val for_all: ('a elt -> bool) -> 'a t -> bool + (** [for_all p s] checks if all elements of the set + satisfy the predicate [p]. *) + + val exists: ('a elt -> bool) -> 'a t -> bool + (** [exists p s] checks if at least one element of + the set satisfies the predicate [p]. *) + + val filter: ('a elt -> bool) -> 'a t -> 'a t + (** [filter p s] returns the set of all elements in [s] + that satisfy predicate [p]. *) + + val partition: ('a elt -> bool) -> 'a t -> 'a t * 'a t + (** [partition p s] returns a pair of sets [(s1, s2)], where + [s1] is the set of all the elements of [s] that satisfy the + predicate [p], and [s2] is the set of all the elements of + [s] that do not satisfy [p]. *) + + val cardinal: 'a t -> int + (** Return the number of elements of a set. *) + + val elements: 'a t -> 'a elt list + (** Return the list of all elements of the given set. + The returned list is sorted in increasing order with respect + to the ordering [Ord.compare], where [Ord] is the argument + given to {!Set.Make}. *) + + val min_elt: 'a t -> 'a elt + (** Return the smallest element of the given set + (with respect to the [Ord.compare] ordering), or raise + [Not_found] if the set is empty. *) + + val max_elt: 'a t -> 'a elt + (** Same as {!Set.S.min_elt}, but returns the largest element of the + given set. *) + + val choose: 'a t -> 'a elt + (** Return one element of the given set, or raise [Not_found] if + the set is empty. Which element is chosen is unspecified, + but equal elements will be chosen for equal sets. *) + end +(** Output signature of the functor {!Set.Make}. *) + +module Make (Ord : PolyOrderedType) : S with type 'a elt = 'a Ord.t +(** Functor building an implementation of the set structure + given a totally ordered type. *) diff --git a/cil/src/ext/pta/steensgaard.ml b/cil/src/ext/pta/steensgaard.ml new file mode 100644 index 0000000..6368693 --- /dev/null +++ b/cil/src/ext/pta/steensgaard.ml @@ -0,0 +1,1417 @@ +(* + * + * Copyright (c) 2001-2002, + * John Kodumal + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(***********************************************************************) +(* *) +(* *) +(* This file is currently unused by CIL. It is included in the *) +(* distribution for reference only. *) +(* *) +(* *) +(***********************************************************************) + + +(***********************************************************************) +(* *) +(* Type Declarations *) +(* *) +(***********************************************************************) + +exception Inconsistent of string +exception Bad_cache +exception No_contents +exception Bad_proj +exception Bad_type_copy +exception Instantiation_cycle + +module U = Uref +module S = Setp +module H = Hashtbl +module Q = Queue + +(** Polarity kinds-- positive, negative, or nonpolar. *) +type polarity = Pos + | Neg + | Non + +(** Label bounds. The polymorphic type is a hack for recursive modules *) +type 'a bound = {index : int; info : 'a} + +(** The 'a type may in general contain urefs, which makes Pervasives.compare + incorrect. However, the bounds will always be correct because if two tau's + get unified, their cached instantiations will be re-entered into the + worklist, ensuring that any labels find the new bounds *) +module Bound = +struct + type 'a t = 'a bound + let compare (x : 'a t) (y : 'a t) = + Pervasives.compare x y +end + +module B = S.Make(Bound) + +type 'a boundset = 'a B.t + +(** Constants, which identify elements in points-to sets *) +type constant = int * string + +module Constant = +struct + type t = constant + + let compare ((xid,_) : t) ((yid,_) : t) = + Pervasives.compare xid yid +end + +module C = Set.Make(Constant) + +(** Sets of constants. Set union is used when two labels containing + constant sets are unified *) +type constantset = C.t + +type lblinfo = { + mutable l_name: string; + (** Name of this label *) + mutable aliases: constantset; + (** Set of constants (tags) for checking aliases *) + p_bounds: label boundset U.uref; + (** Set of umatched (p) lower bounds *) + n_bounds: label boundset U.uref; + (** Set of unmatched (n) lower bounds *) + mutable p_cached: bool; + (** Flag indicating whether all reachable p edges have been locally cached *) + mutable n_cached: bool; + (** Flag indicating whether all reachable n edges have been locally cached *) + mutable on_path: bool; + (** For cycle detection during reachability queries *) +} + +(** Constructor labels *) +and label = lblinfo U.uref + +(** The type of lvalues. *) +type lvalue = { + l: label; + contents: tau +} + +(** Data for variables. *) +and vinfo = { + v_name: string; + mutable v_global: bool; + v_cache: cache +} + +(** Data for ref constructors. *) +and rinfo = { + rl: label; + mutable r_global: bool; + points_to: tau; + r_cache: cache +} + +(** Data for fun constructors. *) +and finfo = { + fl: label; + mutable f_global: bool; + args: tau list ref; + ret: tau; + f_cache: cache +} + +(* Data for pairs. Note there is no label. *) +and pinfo = { + mutable p_global: bool; + ptr: tau; + lam: tau; + p_cache: cache +} + +(** Type constructors discovered by type inference *) +and tinfo = Wild + | Var of vinfo + | Ref of rinfo + | Fun of finfo + | Pair of pinfo + +(** The top-level points-to type. *) +and tau = tinfo U.uref + +(** The instantiation constraint cache. The index is used as a key. *) +and cache = (int,polarity * tau) H.t + +(* Type of semi-unification constraints *) +type su_constraint = Instantiation of tau * (int * polarity) * tau + | Unification of tau * tau + +(** Association lists, used for printing recursive types. The first element + is a type that has been visited. The second element is the string + representation of that type (so far). If the string option is set, then + this type occurs within itself, and is associated with the recursive var + name stored in the option. When walking a type, add it to an association + list. + + Example : suppose we have the constraint 'a = ref('a). The type is unified + via cyclic unification, and would loop infinitely if we attempted to print + it. What we want to do is print the type u rv. ref(rv). This is accomplished + in the following manner: + + -- ref('a) is visited. It is not in the association list, so it is added + and the string "ref(" is stored in the second element. We recurse to print + the first argument of the constructor. + + -- In the recursive call, we see that 'a (or ref('a)) is already in the + association list, so the type is recursive. We check the string option, + which is None, meaning that this is the first recurrence of the type. We + create a new recursive variable, rv and set the string option to 'rv. Next, + we prepend u rv. to the string representation we have seen before, "ref(", + and return "rv" as the string representation of this type. + + -- The string so far is "u rv.ref(". The recursive call returns, and we + complete the type by printing the result of the call, "rv", and ")" + + In a type where the recursive variable appears twice, e.g. 'a = pair('a,'a), + the second time we hit 'a, the string option will be set, so we know to + reuse the same recursive variable name. +*) +type association = tau * string ref * string option ref + +(***********************************************************************) +(* *) +(* Global Variables *) +(* *) +(***********************************************************************) + +(** Print the instantiations constraints (loops with cyclic structures). *) +let print_constraints : bool ref = ref false + +(** Solve constraints as they are introduced. If this is false, constraints + are solved in batch fashion at calls to solveConstraints. *) +let solve_online : bool ref = ref true + +(** If true, print all constraints (including induced) and show additional + debug output. *) +let debug = ref false +let debug_constraints = debug + +(** If true, print out extra verbose debug information (including contents + of label sets *) +let verbose_debug = ref false + + +(** If true, make the flow step a no-op *) +let no_flow = ref false + +let no_sub = ref false + +(** If true, do not add instantiation constraints *) +let analyze_mono = ref false + +(** A counter for generating unique integers. *) +let counter : int ref = ref 0 + +(** A list of equality constraints. *) +let eq_worklist : su_constraint Q.t = Q.create() + +(** A list of instantiation constraints. *) +let inst_worklist : su_constraint Q.t = Q.create() + +(***********************************************************************) +(* *) +(* Utility Functions *) +(* *) +(***********************************************************************) + +(** Consistency check for inferred types *) +let pair_or_var (t : tau) = + match (U.deref t) with + | Pair _ -> true + | Var _ -> true + | _ -> false + +let ref_or_var (t : tau) = + match (U.deref t) with + | Ref _ -> true + | Var _ -> true + | _ -> false + +let fun_or_var (t : tau) = + match (U.deref t) with + | Fun _ -> true + | Var _ -> true + | _ -> false + +(** Generate a unique integer. *) +let fresh_index () : int = + incr counter; + !counter + +(** Negate a polarity. *) +let negate (p : polarity) : polarity = + match p with + | Pos -> Neg + | Neg -> Pos + | Non -> Non + +(** Compute the least-upper-bounds of two polarities. *) +let lub (p,p' : polarity * polarity) : polarity = + match p with + | Pos -> + begin + match p' with + | Pos -> Pos + | _ -> Non + end + | Neg -> + begin + match p' with + | Neg -> Neg + | _ -> Non + end + | Non -> Non + +(** Extract the cache from a type *) +let get_cache (t : tau) : cache = + match U.deref t with + | Wild -> raise Bad_cache + | Var v -> v.v_cache + | Ref r -> r.r_cache + | Pair p -> p.p_cache + | Fun f -> f.f_cache + +(** Determine whether or not a type is global *) +let get_global (t : tau) : bool = + match U.deref t with + | Wild -> false + | Var v -> v.v_global + | Ref r -> r.r_global + | Pair p -> p.p_global + | Fun f -> f.f_global + +(** Return true if a type is monomorphic (global). *) +let global_tau = get_global + +let global_lvalue lv = get_global lv.contents + +(** Return true if e is a member of l (according to uref equality) *) +let rec ulist_mem e l = + match l with + | [] -> false + | h :: t -> if (U.equal(h,e)) then true else ulist_mem e t + +(** Convert a polarity to a string *) +let string_of_polarity p = + match p with + | Pos -> "+" + | Neg -> "-" + | Non -> "T" + +(** Convert a label to a string, short representation *) +let string_of_label2 (l : label) : string = + "\"" ^ (U.deref l).l_name ^ "\"" + +(** Convert a label to a string, long representation *) +let string_of_label (l : label ) : string = + let rec constset_to_string = function + | (_,s) :: [] -> s + | (_,s) :: t -> s ^ "," ^ (constset_to_string t) + | [] -> "" + in + let aliases = constset_to_string (C.elements ((U.deref l).aliases)) + in + if ( (aliases = "") || (not !verbose_debug)) + then string_of_label2 l + else aliases + +(** Return true if the element [e] is present in the association list *) +let rec assoc_list_mem (e : tau) (l : association list) = + match l with + | [] -> None + | (h,s,so) :: t -> + if (U.equal(h,e)) then (Some (s,so)) else assoc_list_mem e t + +(** Given a tau, create a unique recursive variable name. This should always + return the same name for a given tau *) +let fresh_recvar_name (t : tau) : string = + match U.deref t with + | Pair p -> "rvp" ^ string_of_int((Hashtbl.hash p)) + | Ref r -> "rvr" ^ string_of_int((Hashtbl.hash r)) + | Fun f -> "rvf" ^ string_of_int((Hashtbl.hash f)) + | _ -> raise (Inconsistent ("recvar_name")) + +(** Return a string representation of a tau, using association lists. *) +let string_of_tau (t : tau ) : string = + let tau_map : association list ref = ref [] in + let rec string_of_tau' t = + match (assoc_list_mem t (!tau_map)) with + | Some (s,so) -> (* recursive type. see if a var name has been set *) + begin + match (!so) with + | None -> + begin + let rv = fresh_recvar_name(t) in + s := "u " ^ rv ^ "." ^ (!s); + so := Some (rv); + rv + end + | Some rv -> rv + end + | None -> (* type's not recursive. Add it to the assoc list and cont. *) + let s = ref "" in + let so : string option ref = ref None in + begin + tau_map := (t,s,so) :: (!tau_map); + + (match (U.deref t) with + | Wild -> s := "_"; + | Var v -> s := v.v_name; + | Pair p -> + begin + assert (ref_or_var(p.ptr)); + assert (fun_or_var(p.lam)); + s := "{"; + s := (!s) ^ (string_of_tau' p.ptr); + s := (!s) ^ ","; + s := (!s) ^ (string_of_tau' p.lam); + s := (!s) ^"}" + + end + | Ref r -> + begin + assert(pair_or_var(r.points_to)); + s := "ref(|"; + s := (!s) ^ (string_of_label r.rl); + s := (!s) ^ "|,"; + s := (!s) ^ (string_of_tau' r.points_to); + s := (!s) ^ ")" + + end + | Fun f -> + begin + assert(pair_or_var(f.ret)); + let rec string_of_args = function + | h :: [] -> + begin + assert(pair_or_var(h)); + s := (!s) ^ (string_of_tau' h) + end + | h :: t -> + begin + assert(pair_or_var(h)); + s := (!s) ^ (string_of_tau' h) ^ ","; + string_of_args t + end + | [] -> () + in + s := "fun(|"; + s := (!s) ^ (string_of_label f.fl); + s := (!s) ^ "|,"; + s := (!s) ^ "<"; + if (List.length !(f.args) > 0) + then + string_of_args !(f.args) + else + s := (!s) ^ "void"; + s := (!s) ^">,"; + s := (!s) ^ (string_of_tau' f.ret); + s := (!s) ^ ")" + end); + tau_map := List.tl (!tau_map); + !s + end + in + string_of_tau' t + +(** Convert an lvalue to a string *) +let rec string_of_lvalue (lv : lvalue) : string = + let contents = (string_of_tau(lv.contents)) in + let l = (string_of_label lv.l) in + assert(pair_or_var(lv.contents)); + Printf.sprintf "[%s]^(%s)" contents l + +(** Print a list of tau elements, comma separated *) +let rec print_tau_list (l : tau list) : unit = + let t_strings = List.map string_of_tau l in + let rec print_t_strings = function + | h :: [] -> print_string h; print_newline(); + | h :: t -> print_string h; print_string ", "; print_t_strings t + | [] -> () + in + print_t_strings t_strings + +(** Print a constraint. *) +let print_constraint (c : su_constraint) = + match c with + | Unification (t,t') -> + let lhs = string_of_tau t in + let rhs = string_of_tau t' in + Printf.printf "%s == %s\n" lhs rhs + | Instantiation (t,(i,p),t') -> + let lhs = string_of_tau t in + let rhs = string_of_tau t' in + let index = string_of_int i in + let pol = string_of_polarity p in + Printf.printf "%s <={%s,%s} %s\n" lhs index pol rhs + +(* If [positive] is true, return the p-edge bounds, otherwise, return + the n-edge bounds. *) +let get_bounds (positive : bool) (l : label) : label boundset U.uref = + if (positive) then + (U.deref l).p_bounds + else + (U.deref l).n_bounds + +(** Used for cycle detection during the flow step. Returns true if the + label [l] is found on the current path. *) +let on_path (l : label) : bool = + (U.deref l).on_path + +(** Used for cycle detection during the flow step. Identifies [l] as being + on/off the current path. *) +let set_on_path (l : label) (b : bool) : unit = + (U.deref l).on_path <- b + +(** Make the type a global type *) +let set_global (t : tau) (b : bool) : bool = + if (!debug && b) + then + Printf.printf "Setting a new global : %s\n" (string_of_tau t); + begin + assert ( (not (get_global(t)) ) || b ); + (match U.deref t with + | Wild -> () + | Var v -> v.v_global <- b + | Ref r -> r.r_global <- b + | Pair p -> p.p_global <- b + | Fun f -> f.f_global <- b); + b + end + +(** Return a label's bounds as a string *) +let string_of_bounds (is_pos : bool) (l : label) : string = + let bounds = + if (is_pos) then + U.deref ((U.deref l).p_bounds) + else + U.deref ((U.deref l).n_bounds) + in + B.fold (fun b -> fun res -> res ^ (string_of_label2 b.info) ^ " " + ) bounds "" + +(***********************************************************************) +(* *) +(* Type Operations -- these do not create any constraints *) +(* *) +(***********************************************************************) + +let wild_val = U.uref Wild + +(** The wild (don't care) value. *) +let wild () : tau = + wild_val + +(** Create an lvalue with label [lbl] and tau contents [t]. *) +let make_lval (lbl,t : label * tau) : lvalue = + {l = lbl; contents = t} + +(** Create a new label with name [name]. Also adds a fresh constant + with name [name] to this label's aliases set. *) +let make_label (name : string) : label = + U.uref { + l_name = name; + aliases = (C.add (fresh_index(),name) C.empty); + p_bounds = U.uref (B.empty); + n_bounds = U.uref (B.empty); + p_cached = false; + n_cached = false; + on_path = false + } + +(** Create a new label with an unspecified name and an empty alias set. *) +let fresh_label () : label = + U.uref { + l_name = "l_" ^ (string_of_int (fresh_index())); + aliases = (C.empty); + p_bounds = U.uref (B.empty); + n_bounds = U.uref (B.empty); + p_cached = false; + n_cached = false; + on_path = false + } + +(** Create a fresh bound. *) +let make_bound (i,a : int * 'a) : 'a bound = + {index = i; info = a } + +(** Create a fresh named variable with name '[name]. *) +let make_var (b: bool) (name : string) : tau = + U.uref (Var {v_name = ("'" ^name); + v_global = b; + v_cache = H.create 4}) + +(** Create a fresh unnamed variable (name will be 'fv). *) +let fresh_var () : tau = + make_var false ("fv" ^ (string_of_int (fresh_index())) ) + +(** Create a fresh unnamed variable (name will be 'fi). *) +let fresh_var_i () : tau = + make_var false ("fi" ^ (string_of_int (fresh_index())) ) + +(** Create a Fun constructor. *) +let make_fun (lbl,a,r : label * (tau list) * tau) : tau = + U.uref (Fun {fl = lbl ; + f_global = false; + args = ref a; + ret = r; + f_cache = H.create 4}) + +(** Create a Ref constructor. *) +let make_ref (lbl,pt : label * tau) : tau = + U.uref (Ref {rl = lbl ; + r_global = false; + points_to = pt; + r_cache = H.create 4}) + +(** Create a Pair constructor. *) +let make_pair (p,f : tau * tau) : tau = + U.uref (Pair {ptr = p; + p_global = false; + lam = f; + p_cache = H.create 4}) + +(** Copy the toplevel constructor of [t], putting fresh variables in each + argement of the constructor. *) +let copy_toplevel (t : tau) : tau = + match U.deref t with + | Pair _ -> + make_pair (fresh_var_i(), fresh_var_i()) + | Ref _ -> + make_ref (fresh_label(),fresh_var_i()) + | Fun f -> + let fresh_fn = fun _ -> fresh_var_i() + in + make_fun (fresh_label(), List.map fresh_fn !(f.args) , fresh_var_i()) + | _ -> raise Bad_type_copy + +let pad_args (l,l' : (tau list ref) * (tau list ref)) : unit = + let padding = ref ((List.length (!l)) - (List.length (!l'))) + in + if (!padding == 0) then () + else + let to_pad = + if (!padding > 0) then l' else (padding := -(!padding);l) + in + for i = 1 to (!padding) do + to_pad := (!to_pad) @ [fresh_var()] + done + +(***********************************************************************) +(* *) +(* Constraint Generation/ Resolution *) +(* *) +(***********************************************************************) + +(** Returns true if the constraint has no effect, i.e. either the left-hand + side or the right-hand side is wild. *) +let wild_constraint (t,t' : tau * tau) : bool = + let ti,ti' = U.deref t, U.deref t' in + match ti,ti' with + | Wild, _ -> true + | _, Wild -> true + | _ -> false + +exception Cycle_found + +(** Cycle detection between instantiations. Returns true if there is a cycle + from t to t' *) +let exists_cycle (t,t' : tau * tau) : bool = + let visited : tau list ref = ref [] in + let rec exists_cycle' t = + if (ulist_mem t (!visited)) + then + begin (* + print_string "Instantiation cycle found :"; + print_tau_list (!visited); + print_newline(); + print_string (string_of_tau t); + print_newline(); *) + (* raise Instantiation_cycle *) + (* visited := List.tl (!visited) *) (* check *) + end + else + begin + visited := t :: (!visited); + if (U.equal(t,t')) + then raise Cycle_found + else + H.iter (fun _ -> fun (_,t'') -> + if (U.equal (t,t'')) then () + else + ignore (exists_cycle' t'') + ) (get_cache t) ; + visited := List.tl (!visited) + end + in + try + exists_cycle' t; + false + with + | Cycle_found -> true + +exception Subterm + +(** Returns true if [t'] is a proper subterm of [t] *) +let proper_subterm (t,t') = + let visited : tau list ref = ref [] in + let rec proper_subterm' t = + if (ulist_mem t (!visited)) + then () (* recursive type *) + else + if (U.equal (t,t')) + then raise Subterm + else + begin + visited := t :: (!visited); + ( + match (U.deref t) with + | Wild -> () + | Var _ -> () + | Ref r -> + proper_subterm' r.points_to + | Pair p -> + proper_subterm' p.ptr; + proper_subterm' p.lam + | Fun f -> + proper_subterm' f.ret; + List.iter (proper_subterm') !(f.args) + ); + visited := List.tl (!visited) + end + in + try + if (U.equal(t,t')) then false + else + begin + proper_subterm' t; + false + end + with + | Subterm -> true + +(** The extended occurs check. Search for a cycle of instantiations from [t] + to [t']. If such a cycle exists, check to see that [t'] is a proper subterm + of [t]. If it is, then return true *) +let eoc (t,t') : bool = + if (exists_cycle(t,t') && proper_subterm(t,t')) + then + begin + if (!debug) + then + Printf.printf "Occurs check : %s occurs within %s\n" (string_of_tau t') + (string_of_tau t) + else + (); + true + end + else + false + +(** Resolve an instantiation constraint *) +let rec instantiate_int (t,(i,p),t' : tau * (int * polarity) * tau) = + if ( wild_constraint(t,t') || (not (store(t,(i,p),t'))) || + U.equal(t,t') ) + then () + else + let ti,ti' = U.deref t, U.deref t' in + match ti,ti' with + | Ref r, Ref r' -> + instantiate_ref(r,(i,p),r') + | Fun f, Fun f' -> + instantiate_fun(f,(i,p),f') + | Pair pr, Pair pr' -> + begin + add_constraint_int (Instantiation (pr.ptr,(i,p),pr'.ptr)); + add_constraint_int (Instantiation (pr.lam,(i,p),pr'.lam)) + end + | Var v, _ -> () + | _,Var v' -> + if eoc(t,t') + then + add_constraint_int (Unification (t,t')) + else + begin + unstore(t,i); + add_constraint_int (Unification ((copy_toplevel t),t')); + add_constraint_int (Instantiation (t,(i,p),t')) + end + | _ -> raise (Inconsistent("instantiate")) + +(** Apply instantiations to the ref's label, and structurally down the type. + Contents of ref constructors are instantiated with polarity Non. *) +and instantiate_ref (ri,(i,p),ri') : unit = + add_constraint_int (Instantiation(ri.points_to,(i,Non),ri'.points_to)); + instantiate_label (ri.rl,(i,p),ri'.rl) + +(** Apply instantiations to the fun's label, and structurally down the type. + Flip the polarity for the function's args. If the lengths of the argument + lists don't match, extend the shorter list as necessary. *) +and instantiate_fun (fi,(i,p),fi') : unit = + pad_args (fi.args, fi'.args); + assert(List.length !(fi.args) == List.length !(fi'.args)); + add_constraint_int (Instantiation (fi.ret,(i,p),fi'.ret)); + List.iter2 (fun t ->fun t' -> + add_constraint_int (Instantiation(t,(i,negate p),t'))) + !(fi.args) !(fi'.args); + instantiate_label (fi.fl,(i,p),fi'.fl) + +(** Instantiate a label. Update the label's bounds with new flow edges. + *) +and instantiate_label (l,(i,p),l' : label * (int * polarity) * label) : unit = + if (!debug) then + Printf.printf "%s <= {%d,%s} %s\n" (string_of_label l) i + (string_of_polarity p) (string_of_label l'); + let li,li' = U.deref l, U.deref l' in + match p with + | Pos -> + U.update (li'.p_bounds, + B.add(make_bound (i,l)) (U.deref li'.p_bounds) + ) + | Neg -> + U.update (li.n_bounds, + B.add(make_bound (i,l')) (U.deref li.n_bounds) + ) + | Non -> + begin + U.update (li'.p_bounds, + B.add(make_bound (i,l)) (U.deref li'.p_bounds) + ); + U.update (li.n_bounds, + B.add(make_bound (i,l')) (U.deref li.n_bounds) + ) + end + +(** Resolve a unification constraint. Does the uref unification after grabbing + a copy of the information before the two infos are unified. The other + interesting feature of this function is the way 'globalness' is propagated. + If a non-global is unified with a global, the non-global becomes global. + If the ecr became global, there is a problem because none of its cached + instantiations know that the type became monomorphic. In this case, they + must be re-inserted via merge-cache. Merge-cache always reinserts cached + instantiations from the non-ecr type, i.e. the type that was 'killed' by the + unification. *) +and unify_int (t,t' : tau * tau) : unit = + if (wild_constraint(t,t') || U.equal(t,t')) + then () + else + let ti, ti' = U.deref t, U.deref t' in + begin + U.unify combine (t,t'); + match ti,ti' with + | Var v, _ -> + begin + if (set_global t' (v.v_global || (get_global t'))) + then (H.iter (merge_cache t') (get_cache t')) + else (); + H.iter (merge_cache t') v.v_cache + end + | _, Var v -> + begin + if (set_global t (v.v_global || (get_global t))) + then (H.iter (merge_cache t) (get_cache t)) + else (); + H.iter (merge_cache t) v.v_cache + end + | Ref r, Ref r' -> + begin + if (set_global t (r.r_global || r'.r_global)) + then (H.iter (merge_cache t) (get_cache t)) + else (); + H.iter (merge_cache t) r'.r_cache; + unify_ref(r,r') + end + | Fun f, Fun f' -> + begin + if (set_global t (f.f_global || f'.f_global)) + then (H.iter (merge_cache t) (get_cache t)) + else (); + H.iter (merge_cache t) f'.f_cache; + unify_fun (f,f'); + end + | Pair p, Pair p' -> + begin + if (set_global t (p.p_global || p'.p_global)) + then (H.iter (merge_cache t) (get_cache t)) + else (); + H.iter (merge_cache t) p'.p_cache; + add_constraint_int (Unification (p.ptr,p'.ptr)); + add_constraint_int (Unification (p.lam,p'.lam)) + end + | _ -> raise (Inconsistent("unify")) + end + +(** Unify the ref's label, and apply unification structurally down the type. *) +and unify_ref (ri,ri' : rinfo * rinfo) : unit = + add_constraint_int (Unification (ri.points_to,ri'.points_to)); + unify_label(ri.rl,ri'.rl) + +(** Unify the fun's label, and apply unification structurally down the type, + at arguments and return value. When combining two lists of different lengths, + always choose the longer list for the representative. *) +and unify_fun (li,li' : finfo * finfo) : unit = + let rec union_args = function + | _, [] -> false + | [], _ -> true + | h :: t, h' :: t' -> + add_constraint_int (Unification (h,h')); union_args(t,t') + in + begin + unify_label(li.fl,li'.fl); + add_constraint_int (Unification (li.ret,li'.ret)); + if (union_args(!(li.args),!(li'.args))) + then li.args := !(li'.args); + end + +(** Unify two labels, combining the set of constants denoting aliases. *) +and unify_label (l,l' : label * label) : unit = + let pick_name (li,li' : lblinfo * lblinfo) = + if ( (String.length li.l_name) > 1 && (String.sub (li.l_name) 0 2) = "l_") + then + li.l_name <- li'.l_name + else () + in + let combine_label (li,li' : lblinfo *lblinfo) : lblinfo = + let p_bounds = U.deref (li.p_bounds) in + let p_bounds' = U.deref (li'.p_bounds) in + let n_bounds = U.deref (li.n_bounds) in + let n_bounds' = U.deref (li'.n_bounds) in + begin + pick_name(li,li'); + li.aliases <- C.union (li.aliases) (li'.aliases); + U.update (li.p_bounds, (B.union p_bounds p_bounds')); + U.update (li.n_bounds, (B.union n_bounds n_bounds')); + li + end + in(* + if (!debug) then + begin + Printf.printf "Unifying %s with %s...\n" + (string_of_label l) (string_of_label l'); + Printf.printf "pbounds : %s\n" (string_of_bounds true l); + Printf.printf "nbounds : %s\n" (string_of_bounds false l); + Printf.printf "pbounds : %s\n" (string_of_bounds true l'); + Printf.printf "nbounds : %s\n\n" (string_of_bounds false l') + end; *) + U.unify combine_label (l,l') + (* if (!debug) then + begin + Printf.printf "pbounds : %s\n" (string_of_bounds true l); + Printf.printf "nbounds : %s\n" (string_of_bounds false l) + end *) + +(** Re-assert a cached instantiation constraint, since the old type was + killed by a unification *) +and merge_cache (rep : tau) (i : int) (p,t' : polarity * tau) : unit = + add_constraint_int (Instantiation (rep,(i,p),t')) + +(** Pick the representative info for two tinfo's. This function prefers the + first argument when both arguments are the same structure, but when + one type is a structure and the other is a var, it picks the structure. *) +and combine (ti,ti' : tinfo * tinfo) : tinfo = + match ti,ti' with + | Var _, _ -> ti' + | _,_ -> ti + +(** Add a new constraint induced by other constraints. *) +and add_constraint_int (c : su_constraint) = + if (!print_constraints && !debug) then print_constraint c else (); + begin + match c with + | Instantiation _ -> + Q.add c inst_worklist + | Unification _ -> + Q.add c eq_worklist + end; + if (!debug) then solve_constraints() else () + +(** Add a new constraint introduced through this module's interface (a + top-level constraint). *) +and add_constraint (c : su_constraint) = + begin + add_constraint_int (c); + if (!print_constraints && not (!debug)) then print_constraint c else (); + if (!solve_online) then solve_constraints() else () + end + + +(* Fetch constraints, preferring equalities. *) +and fetch_constraint () : su_constraint option = + if (Q.length eq_worklist > 0) + then + Some (Q.take eq_worklist) + else if (Q.length inst_worklist > 0) + then + Some (Q.take inst_worklist) + else + None + +(** Returns the target of a cached instantiation, if it exists. *) +and target (t,i,p : tau * int * polarity) : (polarity * tau) option = + let cache = get_cache t in + if (global_tau t) then Some (Non,t) + else + try + Some (H.find cache i) + with + | Not_found -> None + +(** Caches a new instantiation, or applies well-formedness. *) +and store ( t,(i,p),t' : tau * (int * polarity) * tau) : bool = + let cache = get_cache t in + match target(t,i,p) with + | Some (p'',t'') -> + if (U.equal (t',t'') && (lub(p,p'') = p'')) + then + false + else + begin + add_constraint_int (Unification (t',t'')); + H.replace cache i (lub(p,p''),t''); + (* add a new forced instantiation as well *) + if (lub(p,p'') = p'') + then () + else + begin + unstore(t,i); + add_constraint_int (Instantiation (t,(i,lub(p,p'')),t'')) + end; + false + end + | None -> + begin + H.add cache i (p,t'); + true + end + +(** Remove a cached instantiation. Used when type structure changes *) +and unstore (t,i : tau * int) = +let cache = get_cache t in + H.remove cache i + +(** The main solver loop. *) +and solve_constraints () : unit = + match fetch_constraint () with + | Some c -> + begin + (match c with + | Instantiation (t,(i,p),t') -> instantiate_int (t,(i,p),t') + | Unification (t,t') -> unify_int (t,t') + ); + solve_constraints() + end + | None -> () + + +(***********************************************************************) +(* *) +(* Interface Functions *) +(* *) +(***********************************************************************) + +(** Return the contents of the lvalue. *) +let rvalue (lv : lvalue) : tau = + lv.contents + +(** Dereference the rvalue. If it does not have enough structure to support + the operation, then the correct structure is added via new unification + constraints. *) +let rec deref (t : tau) : lvalue = + match U.deref t with + | Pair p -> + ( + match U.deref (p.ptr) with + | Var _ -> + begin + (* let points_to = make_pair(fresh_var(),fresh_var()) in *) + let points_to = fresh_var() in + let l = fresh_label() in + let r = make_ref(l,points_to) + in + add_constraint (Unification (p.ptr,r)); + make_lval(l, points_to) + end + | Ref r -> make_lval(r.rl, r.points_to) + | _ -> raise (Inconsistent("deref")) + ) + | Var v -> + begin + add_constraint (Unification (t,make_pair(fresh_var(),fresh_var()))); + deref t + end + | _ -> raise (Inconsistent("deref -- no top level pair")) + +(** Form the union of [t] and [t']. *) +let join (t : tau) (t' : tau) : tau = + let t'' = fresh_var() in + add_constraint (Unification (t,t'')); + add_constraint (Unification (t',t'')); + t'' + +(** Form the union of a list [tl], expected to be the initializers of some + structure or array type. *) +let join_inits (tl : tau list) : tau = + let t' = fresh_var() in + begin + List.iter (function t'' -> add_constraint (Unification(t',t''))) tl; + t' + end + +(** Take the address of an lvalue. Does not add constraints. *) +let address (lv : lvalue) : tau = + make_pair (make_ref (lv.l, lv.contents), fresh_var() ) + +(** Instantiate a type with index i. By default, uses positive polarity. + Adds an instantiation constraint. *) +let instantiate (lv : lvalue) (i : int) : lvalue = + if (!analyze_mono) then lv + else + begin + let l' = fresh_label () in + let t' = fresh_var_i () in + instantiate_label(lv.l,(i,Pos),l'); + add_constraint (Instantiation (lv.contents,(i,Pos),t')); + make_lval(l',t') (* check -- fresh label ?? *) + end + +(** Constraint generated from assigning [t] to [lv]. *) +let assign (lv : lvalue) (t : tau) : unit = + add_constraint (Unification (lv.contents,t)) + + +(** Project out the first (ref) component or a pair. If the argument [t] has + no discovered structure, raise No_contents. *) +let proj_ref (t : tau) : tau = + match U.deref t with + | Pair p -> p.ptr + | Var v -> raise No_contents + | _ -> raise Bad_proj + +(* Project out the second (fun) component of a pair. If the argument [t] has + no discovered structure, create it on the fly by adding constraints. *) +let proj_fun (t : tau) : tau = + match U.deref t with + | Pair p -> p.lam + | Var v -> + let p,f = fresh_var(), fresh_var() in + add_constraint (Unification (t,make_pair(p,f))); + f + | _ -> raise Bad_proj + +let get_args (t : tau) : tau list ref = + match U.deref t with + | Fun f -> f.args + | _ -> raise (Inconsistent("get_args")) + +(** Function type [t] is applied to the arguments [actuals]. Unifies the + actuals with the formals of [t]. If no functions have been discovered for + [t] yet, create a fresh one and unify it with t. The result is the return + value of the function. *) +let apply (t : tau) (al : tau list) : tau = + let f = proj_fun(t) in + let actuals = ref al in + let formals,ret = + match U.deref f with + | Fun fi -> (fi.args),fi.ret + | Var v -> + let new_l,new_ret,new_args = + fresh_label(), fresh_var (), + List.map (function _ -> fresh_var()) (!actuals) + in + let new_fun = make_fun(new_l,new_args,new_ret) in + add_constraint (Unification(new_fun,f)); + (get_args new_fun,new_ret) + | Ref _ -> raise (Inconsistent ("apply_ref")) + | Pair _ -> raise (Inconsistent ("apply_pair")) + | Wild -> raise (Inconsistent("apply_wild")) + in + pad_args(formals,actuals); + List.iter2 (fun actual -> fun formal -> + add_constraint (Unification (actual,formal)) + ) !actuals !formals; + ret + +(** Create a new function type with name [name], list of formal arguments + [formals], and return value [ret]. Adds no constraints. *) +let make_function (name : string) (formals : lvalue list) (ret : tau) : tau = + let + f = make_fun(make_label(name),List.map (fun x -> rvalue x) formals, ret) + in + make_pair(fresh_var(),f) + +(** Create an lvalue. If [is_global] is true, the lvalue will be treated + monomorphically. *) +let make_lvalue (is_global : bool) (name : string) : lvalue = + if (!debug && is_global) + then + Printf.printf "Making global lvalue : %s\n" name + else (); + make_lval(make_label(name), make_var is_global name) + + +(** Create a fresh non-global named variable. *) +let make_fresh (name : string) : tau = + make_var false (name) + +(** The default type for constants. *) +let bottom () : tau = + make_var false ("bottom") + +(** Unify the result of a function with its return value. *) +let return (t : tau) (t' : tau) = + add_constraint (Unification (t,t')) + + +(***********************************************************************) +(* *) +(* Query/Extract Solutions *) +(* *) +(***********************************************************************) + +(** Unify the data stored in two label bounds. *) +let combine_lbounds (s,s' : label boundset * label boundset) = + B.union s s' + +(** Truncates a list of urefs [l] to those elements up to and including the + first occurence of the specified element [elt]. *) +let truncate l elt = + let keep = ref true in + List.filter + (fun x -> + if (not (!keep)) + then + false + else + begin + if (U.equal(x,elt)) + then + keep := false + else (); + true + end + ) l + +let debug_cycle_bounds is_pos c = + let rec debug_cycle_bounds' = function + | h :: [] -> + Printf.printf "%s --> %s\n" (string_of_bounds is_pos h) + (string_of_label2 h) + | h :: t -> + begin + Printf.printf "%s --> %s\n" (string_of_bounds is_pos h) + (string_of_label2 h); + debug_cycle_bounds' t + end + | [] -> () + in + debug_cycle_bounds' c + +(** For debugging, print a cycle of instantiations *) +let debug_cycle (is_pos,c,l,p) = + let kind = if is_pos then "P" else "N" in + let rec string_of_cycle = function + | h :: [] -> string_of_label2 h + | [] -> "" + | h :: t -> Printf.sprintf "%s,%s" (string_of_label2 h) (string_of_cycle t) + in + Printf.printf "Collapsing %s cycle around %s:\n" kind (string_of_label2 l); + Printf.printf "Elements are: %s\n" (string_of_cycle c); + Printf.printf "Per-element bounds:\n"; + debug_cycle_bounds is_pos c; + Printf.printf "Full path is: %s" (string_of_cycle p); + print_newline() + +(** Compute pos or neg flow, depending on [is_pos]. Searches for cycles in the + instantiations (can these even occur?) and unifies either the positive or + negative edge sets for the labels on the cycle. Note that this does not + ever unify the labels themselves. The return is the new bounds of the + argument label *) +let rec flow (is_pos : bool) (path : label list) (l : label) : label boundset = + let collapse_cycle () = + let cycle = truncate path l in + debug_cycle (is_pos,cycle,l,path); + List.iter (fun x -> U.unify combine_lbounds + ((get_bounds is_pos x),get_bounds is_pos l) + ) cycle + in + if (on_path l) + then + begin + collapse_cycle (); + (* set_on_path l false; *) + B.empty + end + else + if ( (is_pos && (U.deref l).p_cached) || + ( (not is_pos) && (U.deref l).n_cached) ) then + begin + U.deref (get_bounds is_pos l) + end + else + begin + let newbounds = ref B.empty in + let base = get_bounds is_pos l in + set_on_path l true; + if (is_pos) then + (U.deref l).p_cached <- true + else + (U.deref l).n_cached <- true; + B.iter + (fun x -> + if (U.equal(x.info,l)) then () + else + (newbounds := + (B.union (!newbounds) (flow is_pos (l :: path) x.info))) + ) (U.deref base); + set_on_path l false; + U.update (base,(B.union (U.deref base) !newbounds)); + U.deref base + end + +(** Compute and cache any positive flow. *) +let pos_flow l : constantset = + let result = ref C.empty in + begin + ignore (flow true [] l); + B.iter (fun x -> result := C.union (!result) (U.deref(x.info)).aliases ) + (U.deref (get_bounds true l)); + !result + end + +(** Compute and cache any negative flow. *) +let neg_flow l : constantset = + let result = ref C.empty in + begin + ignore (flow false [] l); + B.iter (fun x -> result := C.union (!result) (U.deref(x.info)).aliases ) + (U.deref (get_bounds false l)); + !result + end + +(** Compute and cache any pos-neg flow. Assumes that both pos_flow and + neg_flow have been computed for the label [l]. *) +let pos_neg_flow(l : label) : constantset = + let result = ref C.empty in + begin + B.iter (fun x -> result := C.union (!result) (pos_flow x.info)) + (U.deref (get_bounds false l)); + !result + end + +(** Compute a points-to set by computing positive, then negative, then + positive-negative flow for a label. *) +let points_to_int (lv : lvalue) : constantset = + let visited_caches : cache list ref = ref [] in + let rec points_to_tau (t : tau) : constantset = + try + begin + match U.deref (proj_ref t) with + | Var v -> C.empty + | Ref r -> + begin + let pos = pos_flow r.rl in + let neg = neg_flow r.rl in + let interproc = C.union (pos_neg_flow r.rl) (C.union pos neg) + in + C.union ((U.deref(r.rl)).aliases) interproc + end + | _ -> raise (Inconsistent ("points_to")) + end + with + | No_contents -> + begin + match (U.deref t) with + | Var v -> rebuild_flow v.v_cache + | _ -> raise (Inconsistent ("points_to")) + end + and rebuild_flow (c : cache) : constantset = + if (List.mem c (!visited_caches) ) (* cyclic instantiations *) + then + begin + (* visited_caches := List.tl (!visited_caches); *) (* check *) + C.empty + end + else + begin + visited_caches := c :: (!visited_caches); + let result = ref (C.empty) in + H.iter (fun _ -> fun(p,t) -> + match p with + | Pos -> () + | _ -> result := C.union (!result) (points_to_tau t) + ) c; + visited_caches := List.tl (!visited_caches); + !result + end + in + if (!no_flow) then + (U.deref lv.l).aliases + else + points_to_tau (lv.contents) + +let points_to (lv : lvalue) : string list = + List.map snd (C.elements (points_to_int lv)) + +let alias_query (a_progress : bool) (lv : lvalue list) : int * int = + (0,0) (* todo *) +(* + let a_count = ref 0 in + let ptsets = List.map points_to_int lv in + let total_sets = List.length ptsets in + let counted_sets = ref 0 in + let record_alias s s' = + if (C.is_empty (C.inter s s')) + then () + else (incr a_count) + in + let rec check_alias = function + | h :: t -> + begin + List.iter (record_alias h) ptsets; + check_alias t + end + | [] -> () + in + check_alias ptsets; + !a_count +*) diff --git a/cil/src/ext/pta/steensgaard.mli b/cil/src/ext/pta/steensgaard.mli new file mode 100644 index 0000000..f009e7e --- /dev/null +++ b/cil/src/ext/pta/steensgaard.mli @@ -0,0 +1,71 @@ +(* + * + * Copyright (c) 2001-2002, + * John Kodumal + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(***********************************************************************) +(* *) +(* *) +(* This file is currently unused by CIL. It is included in the *) +(* distribution for reference only. *) +(* *) +(* *) +(***********************************************************************) + +type lvalue +type tau +val debug : bool ref +val debug_constraints : bool ref +val print_constraints : bool ref +val no_flow : bool ref +val no_sub : bool ref +val analyze_mono : bool ref +val solve_online : bool ref +val solve_constraints : unit -> unit +val rvalue : lvalue -> tau +val deref : tau -> lvalue +val join : tau -> tau -> tau +val join_inits : tau list -> tau +val address : lvalue -> tau +val instantiate : lvalue -> int -> lvalue +val assign : lvalue -> tau -> unit +val apply : tau -> tau list -> tau +val make_function : string -> lvalue list -> tau -> tau +val make_lvalue : bool -> string -> lvalue +val bottom : unit -> tau +val return : tau -> tau -> unit +val make_fresh : string -> tau +val points_to : lvalue -> string list +val string_of_lvalue : lvalue -> string +val global_lvalue : lvalue -> bool +val alias_query : bool -> lvalue list -> int * int diff --git a/cil/src/ext/pta/uref.ml b/cil/src/ext/pta/uref.ml new file mode 100644 index 0000000..53f3640 --- /dev/null +++ b/cil/src/ext/pta/uref.ml @@ -0,0 +1,94 @@ +(* + * + * Copyright (c) 2001-2002, + * John Kodumal + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +exception Bad_find + +type 'a urefC = + Ecr of 'a * int + | Link of 'a uref +and 'a uref = 'a urefC ref + +let rec find p = + match !p with + | Ecr _ -> p + | Link p' -> + let p'' = find p' + in p := Link p''; p'' + +let uref x = ref (Ecr(x,0)) + +let equal (p,p') = (find p == find p') + +let deref p = + match ! (find p) with + | Ecr (x,_) -> x + | _ -> raise Bad_find + +let update (p,x) = + let p' = find p + in + match !p' with + | Ecr (_,rank) -> p' := Ecr(x,rank) + | _ -> raise Bad_find + +let unify f (p,q) = + let p',q' = find p, find q in + match (!p',!q') with + | (Ecr(px,pr),Ecr(qx,qr)) -> + let x = f(px,qx) in + if (p' == q') then + p' := Ecr(x,pr) + else if pr == qr then + (q' := Ecr(x,qr+1); p' := Link q') + else if pr < qr then + (q' := Ecr(x,qr); p' := Link q') + else (* pr > qr *) + (p' := Ecr(x,pr); q' := Link p') + | _ -> raise Bad_find + +let union (p,q) = + let p',q' = find p, find q in + match (!p',!q') with + | (Ecr(px,pr),Ecr(qx,qr)) -> + if (p' == q') then + () + else if pr == qr then + (q' := Ecr(qx, qr+1); p' := Link q') + else if pr < qr then + p' := Link q' + else (* pr > qr *) + q' := Link p' + | _ -> raise Bad_find + + diff --git a/cil/src/ext/pta/uref.mli b/cil/src/ext/pta/uref.mli new file mode 100644 index 0000000..1dee503 --- /dev/null +++ b/cil/src/ext/pta/uref.mli @@ -0,0 +1,65 @@ +(* + * + * Copyright (c) 2001-2002, + * John Kodumal + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +type 'a uref + +(** Union-find with union by rank and path compression + + This is an implementation of Tarjan's union-find data structure using + generics. The interface is analagous to standard references, with the + addition of a union operation which makes two references indistinguishable. + +*) + +val uref: 'a -> 'a uref + (** Create a new uref *) + +val equal: 'a uref * 'a uref -> bool + (** Test whether two urefs share the same equivalence class *) + +val deref: 'a uref -> 'a + (** Extract the contents of this reference *) + +val update: 'a uref * 'a -> unit + (** Update the value stored in this reference *) + +val unify: ('a * 'a -> 'a) -> 'a uref * 'a uref -> unit + (** [unify f (p,q)] unifies references [p] and [q], making them + indistinguishable. The contents of the reference are the result of + [f] *) + +val union: 'a uref * 'a uref -> unit + (** [unify (p,q)] unifies references [p] and [q], making them + indistinguishable. The contents of the reference are the contents of + one of the first or second arguments (unspecified) *) diff --git a/cil/src/ext/reachingdefs.ml b/cil/src/ext/reachingdefs.ml new file mode 100644 index 0000000..b6af37c --- /dev/null +++ b/cil/src/ext/reachingdefs.ml @@ -0,0 +1,511 @@ +(* Calculate reaching definitions for each instruction. + * Determine when it is okay to replace some variables with + * expressions. + * + * After calling computeRDs on a fundec, + * ReachingDef.stmtStartData will contain a mapping from + * statement ids to data about which definitions reach each + * statement. ReachingDef.defIdStmtHash will contain a + * mapping from definition ids to the statement in which + * that definition takes place. + * + * instrRDs takes a list of instructions, and the + * definitions that reach the first instruction, and + * for each instruction figures out which definitions + * reach into or out of each instruction. + * + *) + +open Cil +open Pretty + +module E = Errormsg +module DF = Dataflow +module UD = Usedef +module IH = Inthash +module U = Util +module S = Stats + +let debug_fn = ref "" + +module IOS = + Set.Make(struct + type t = int option + let compare io1 io2 = + match io1, io2 with + Some i1, Some i2 -> Pervasives.compare i1 i2 + | Some i1, None -> 1 + | None, Some i2 -> -1 + | None, None -> 0 + end) + +let debug = ref false + +(* return the intersection of + Inthashes ih1 and ih2 *) +let ih_inter ih1 ih2 = + let ih' = IH.copy ih1 in + IH.iter (fun id vi -> + if not(IH.mem ih2 id) then + IH.remove ih' id else + ()) ih1; + ih' + +let ih_union ih1 ih2 = + let ih' = IH.copy ih1 in + IH.iter (fun id vi -> + if not(IH.mem ih' id) + then IH.add ih' id vi + else ()) ih2; + ih' + +(* Lookup varinfo in iosh. If the set contains None + or is not a singleton, return None, otherwise + return Some of the singleton *) +(* IOS.t IH.t -> varinfo -> int option *) +let iosh_singleton_lookup iosh vi = + if IH.mem iosh vi.vid then + let ios = IH.find iosh vi.vid in + if not (IOS.cardinal ios = 1) then None + else IOS.choose ios + else None + +(* IOS.t IH.t -> varinfo -> IOS.t *) +let iosh_lookup iosh vi = + if IH.mem iosh vi.vid + then Some(IH.find iosh vi.vid) + else None + +(* return Some(vid) if iosh contains defId. + return None otherwise *) +(* IOS.t IH.t -> int -> int option *) +let iosh_defId_find iosh defId = + (* int -> IOS.t -> int option -> int option*) + let get_vid vid ios io = + match io with + Some(i) -> Some(i) + | None -> + let there = IOS.exists + (function None -> false + | Some(i') -> defId = i') ios in + if there then Some(vid) else None + in + IH.fold get_vid iosh None + +(* The resulting iosh will contain the + union of the same entries from iosh1 and + iosh2. If iosh1 has an entry that iosh2 + does not, then the result will contain + None in addition to the things from the + entry in iosh1. *) +(* XXX this function is a performance bottleneck *) +let iosh_combine iosh1 iosh2 = + let iosh' = IH.copy iosh1 in + IH.iter (fun id ios1 -> + try let ios2 = IH.find iosh2 id in + let newset = IOS.union ios1 ios2 in + IH.replace iosh' id newset; + with Not_found -> + let newset = IOS.add None ios1 in + IH.replace iosh' id newset) iosh1; + IH.iter (fun id ios2 -> + if not(IH.mem iosh1 id) then + let newset = IOS.add None ios2 in + IH.add iosh' id newset) iosh2; + iosh' + + +(* determine if two IOS.t IH.t s are the same *) +let iosh_equals iosh1 iosh2 = +(* if IH.length iosh1 = 0 && not(IH.length iosh2 = 0) || + IH.length iosh2 = 0 && not(IH.length iosh1 = 0)*) + if not(IH.length iosh1 = IH.length iosh2) + then + (if !debug then ignore(E.log "iosh_equals: length not same\n"); + false) + else + IH.fold (fun vid ios b -> + if not b then b else + try let ios2 = IH.find iosh2 vid in + if not(IOS.compare ios ios2 = 0) then + (if !debug then ignore(E.log "iosh_equals: sets for vid %d not equal\n" vid); + false) + else true + with Not_found -> + (if !debug then ignore(E.log "iosh_equals: vid %d not in iosh2\n" vid); + false)) iosh1 true + +(* replace an entire set with a singleton. + if nothing was there just add the singleton *) +(* IOS.t IH.t -> int -> varinfo -> unit *) +let iosh_replace iosh i vi = + if IH.mem iosh vi.vid then + let newset = IOS.singleton (Some i) in + IH.replace iosh vi.vid newset + else + let newset = IOS.singleton (Some i) in + IH.add iosh vi.vid newset + +(* remove definitions that are killed. + add definitions that are gend *) +(* Takes the defs, the data, and a function for + obtaining the next def id *) +(* VS.t -> IOS.t IH.t -> (unit->int) -> unit *) +let proc_defs vs iosh f = + let pd vi = + let newi = f() in + (*if !debug then + ignore (E.log "proc_defs: genning %d\n" newi);*) + iosh_replace iosh newi vi + in + UD.VS.iter pd vs + +let idMaker () start = + let counter = ref start in + fun () -> + let ret = !counter in + counter := !counter + 1; + ret + +(* given reaching definitions into a list of + instructions, figure out the definitions that + reach in/out of each instruction *) +(* if out is true then calculate the definitions that + go out of each instruction, if it is false then + calculate the definitions reaching into each instruction *) +(* instr list -> int -> (varinfo IH.t * int) -> bool -> (varinfo IH.t * int) list *) +let iRDsHtbl = Hashtbl.create 128 +let instrRDs il sid (ivih, s, iosh) out = + if Hashtbl.mem iRDsHtbl (sid,out) then Hashtbl.find iRDsHtbl (sid,out) else + +(* let print_instr i (_,s', iosh') = *) +(* let d = d_instr () i ++ line in *) +(* fprint stdout 80 d; *) +(* flush stdout *) +(* in *) + + let proc_one hil i = + match hil with + | [] -> + let _, defd = UD.computeUseDefInstr i in + if UD.VS.is_empty defd + then ((*if !debug then print_instr i ((), s, iosh);*) + [((), s, iosh)]) + else + let iosh' = IH.copy iosh in + proc_defs defd iosh' (idMaker () s); + (*if !debug then + print_instr i ((), s + UD.VS.cardinal defd, iosh');*) + ((), s + UD.VS.cardinal defd, iosh')::hil + | (_, s', iosh')::hrst as l -> + let _, defd = UD.computeUseDefInstr i in + if UD.VS.is_empty defd + then + ((*if !debug then + print_instr i ((),s', iosh');*) + ((), s', iosh')::l) + else let iosh'' = IH.copy iosh' in + proc_defs defd iosh'' (idMaker () s'); + (*if !debug then + print_instr i ((), s' + UD.VS.cardinal defd, iosh'');*) + ((),s' + UD.VS.cardinal defd, iosh'')::l + in + let folded = List.fold_left proc_one [((),s,iosh)] il in + let foldedout = List.tl (List.rev folded) in + let foldednotout = List.rev (List.tl folded) in + Hashtbl.add iRDsHtbl (sid,true) foldedout; + Hashtbl.add iRDsHtbl (sid,false) foldednotout; + if out then foldedout else foldednotout + + + +(* The right hand side of an assignment is either + a function call or an expression *) +type rhs = RDExp of exp | RDCall of instr + +(* take the id number of a definition and return + the rhs of the definition if there is one. + Returns None if, for example, the definition is + caused by an assembly instruction *) +(* stmt IH.t -> (()*int*IOS.t IH.t) IH.t -> int -> (rhs * int * IOS.t IH.t) option *) +let rhsHtbl = IH.create 64 (* to avoid recomputation *) +let getDefRhs didstmh stmdat defId = + if IH.mem rhsHtbl defId then IH.find rhsHtbl defId else + let stm = + try IH.find didstmh defId + with Not_found -> E.s (E.error "getDefRhs: defId %d not found\n" defId) in + let (_,s,iosh) = + try IH.find stmdat stm.sid + with Not_found -> E.s (E.error "getDefRhs: sid %d not found \n" stm.sid) in + match stm.skind with + Instr il -> + let ivihl = instrRDs il stm.sid ((),s,iosh) true in (* defs that reach out of each instr *) + let ivihl_in = instrRDs il stm.sid ((),s,iosh) false in (* defs that reach into each instr *) + let iihl = List.combine (List.combine il ivihl) ivihl_in in + (try let ((i,(_,_,diosh)),(_,_,iosh_in)) = List.find (fun ((i,(_,_,iosh')),_) -> + match S.time "iosh_defId_find" (iosh_defId_find iosh') defId with + Some vid -> + (match i with + Set((Var vi',NoOffset),_,_) -> vi'.vid = vid (* _ -> NoOffset *) + | Call(Some(Var vi',NoOffset),_,_,_) -> vi'.vid = vid (* _ -> NoOffset *) + | Call(None,_,_,_) -> false + | Asm(_,_,sll,_,_,_) -> List.exists + (function (_,(Var vi',NoOffset)) -> vi'.vid = vid | _ -> false) sll + | _ -> false) + | None -> false) iihl in + (match i with + Set((lh,_),e,_) -> + (match lh with + Var(vi') -> + (IH.add rhsHtbl defId (Some(RDExp(e),stm.sid,iosh_in)); + Some(RDExp(e), stm.sid, iosh_in)) + | _ -> E.s (E.error "Reaching Defs getDefRhs: right vi not first\n")) + | Call(lvo,e,el,_) -> + (IH.add rhsHtbl defId (Some(RDCall(i),stm.sid,iosh_in)); + Some(RDCall(i), stm.sid, iosh_in)) + | Asm(a,sl,slvl,sel,sl',_) -> None) (* ? *) + with Not_found -> + (if !debug then ignore (E.log "getDefRhs: No instruction defines %d\n" defId); + IH.add rhsHtbl defId None; + None)) + | _ -> E.s (E.error "getDefRhs: defining statement not an instruction list %d\n" defId) + (*None*) + +let prettyprint didstmh stmdat () (_,s,iosh) = text "" + (*seq line (fun (vid,ios) -> + num vid ++ text ": " ++ + IOS.fold (fun io d -> match io with + None -> d ++ text "None " + | Some i -> + let stm = IH.find didstmh i in + match getDefRhs didstmh stmdat i with + None -> d ++ num i + | Some(RDExp(e),_,_) -> + d ++ num i ++ text " " ++ (d_exp () e) + | Some(RDCall(c),_,_) -> + d ++ num i ++ text " " ++ (d_instr () c)) + ios nil) + (IH.tolist iosh)*) + +module ReachingDef = + struct + + let name = "Reaching Definitions" + + let debug = debug + + (* Should the analysis calculate may-reach + or must-reach *) + let mayReach = ref false + + + (* An integer that tells the id number of + the first definition *) + (* Also a hash from variable ids to a set of + definition ids that reach this statement. + None means there is a path to this point on which + there is no definition of the variable *) + type t = (unit * int * IOS.t IH.t) + + let copy (_, i, iosh) = ((), i, IH.copy iosh) + + (* entries for starting statements must + be added before calling compute *) + let stmtStartData = IH.create 32 + + (* a mapping from definition ids to + the statement corresponding to that id *) + let defIdStmtHash = IH.create 32 + + (* mapping from statement ids to statements + for better performance of ok_to_replace *) + let sidStmtHash = IH.create 64 + + (* pretty printer *) + let pretty = prettyprint defIdStmtHash stmtStartData + + + (* The first id to use when computeFirstPredecessor + is next called *) + let nextDefId = ref 0 + + (* Count the number of variable definitions in + a statement *) + let num_defs stm = + match stm.skind with + Instr(il) -> List.fold_left (fun s i -> + let _, d = UD.computeUseDefInstr i in + s + UD.VS.cardinal d) 0 il + | _ -> let _, d = UD.computeUseDefStmtKind stm.skind in + UD.VS.cardinal d + + (* the first predecessor is just the data in along with + the id of the first definition of the statement, + which we get from nextDefId *) + let computeFirstPredecessor stm (_, s, iosh) = + let startDefId = max !nextDefId s in + let numds = num_defs stm in + let rec loop n = + if n < 0 + then () + else + (if !debug then + ignore (E.log "RD: defId %d -> stm %d\n" (startDefId + n) stm.sid); + IH.add defIdStmtHash (startDefId + n) stm; + loop (n-1)) + in + loop (numds - 1); + nextDefId := startDefId + numds; + ((), startDefId, IH.copy iosh) + + + let combinePredecessors (stm:stmt) ~(old:t) ((_, s, iosh):t) = + match old with (_, os, oiosh) -> + if S.time "iosh_equals" (iosh_equals oiosh) iosh then None else + Some((), os, S.time "iosh_combine" (iosh_combine oiosh) iosh) + + (* return an action that removes things that + are redefinied and adds the generated defs *) + let doInstr inst (_, s, iosh) = + let transform (_, s', iosh') = + let _, defd = UD.computeUseDefInstr inst in + proc_defs defd iosh' (idMaker () s'); + ((), s' + UD.VS.cardinal defd, iosh') + in + DF.Post transform + + (* all the work gets done at the instruction level *) + let doStmt stm (_, s, iosh) = + if not(IH.mem sidStmtHash stm.sid) then + IH.add sidStmtHash stm.sid stm; + if !debug then ignore(E.log "RD: looking at %a\n" d_stmt stm); + DF.SDefault + + let doGuard condition _ = DF.GDefault + + let filterStmt stm = true + +end + +module RD = DF.ForwardsDataFlow(ReachingDef) + +(* map all variables in vil to a set containing + None in iosh *) +(* IOS.t IH.t -> varinfo list -> () *) +let iosh_none_fill iosh vil = + List.iter (fun vi -> + IH.add iosh vi.vid (IOS.singleton None)) + vil + +(* Computes the reaching definitions for a + function. *) +(* Cil.fundec -> unit *) +let computeRDs fdec = + try + if compare fdec.svar.vname (!debug_fn) = 0 then + (debug := true; + ignore (E.log "%s =\n%a\n" (!debug_fn) d_block fdec.sbody)); + let bdy = fdec.sbody in + let slst = bdy.bstmts in + let _ = IH.clear ReachingDef.stmtStartData in + let _ = IH.clear ReachingDef.defIdStmtHash in + let _ = IH.clear rhsHtbl in + let _ = Hashtbl.clear iRDsHtbl in + let _ = ReachingDef.nextDefId := 0 in + let fst_stm = List.hd slst in + let fst_iosh = IH.create 32 in + let _ = UD.onlyNoOffsetsAreDefs := false in + (*let _ = iosh_none_fill fst_iosh fdec.sformals in*) + let _ = IH.add ReachingDef.stmtStartData fst_stm.sid ((), 0, fst_iosh) in + let _ = ReachingDef.computeFirstPredecessor fst_stm ((), 0, fst_iosh) in + if !debug then + ignore (E.log "computeRDs: fst_stm.sid=%d\n" fst_stm.sid); + RD.compute [fst_stm]; + if compare fdec.svar.vname (!debug_fn) = 0 then + debug := false + (* now ReachingDef.stmtStartData has the reaching def data in it *) + with Failure "hd" -> if compare fdec.svar.vname (!debug_fn) = 0 then + debug := false + +(* return the definitions that reach the statement + with statement id sid *) +let getRDs sid = + try + Some (IH.find ReachingDef.stmtStartData sid) + with Not_found -> + None +(* E.s (E.error "getRDs: sid %d not found\n" sid) *) + +let getDefIdStmt defid = + try + Some(IH.find ReachingDef.defIdStmtHash defid) + with Not_found -> + None + +let getStmt sid = + try Some(IH.find ReachingDef.sidStmtHash sid) + with Not_found -> None + +(* Pretty print the reaching definition data for + a function *) +let ppFdec fdec = + seq line (fun stm -> + let ivih = IH.find ReachingDef.stmtStartData stm.sid in + ReachingDef.pretty () ivih) fdec.sbody.bstmts + + +(* If this class is extended with a visitor on expressions, + then the current rd data is available at each expression *) +class rdVisitorClass = object (self) + inherit nopCilVisitor + + (* the statement being worked on *) + val mutable sid = -1 + + (* if a list of instructions is being processed, + then this is the corresponding list of + reaching definitions *) + val mutable rd_dat_lst = [] + + (* these are the reaching defs for the current + instruction if there is one *) + val mutable cur_rd_dat = None + + method vstmt stm = + sid <- stm.sid; + match getRDs sid with + None -> + if !debug then ignore(E.log "rdVis: stm %d had no data\n" sid); + cur_rd_dat <- None; + DoChildren + | Some(_,s,iosh) -> + match stm.skind with + Instr il -> + if !debug then ignore(E.log "rdVis: visit il\n"); + rd_dat_lst <- instrRDs il stm.sid ((),s,iosh) false; + DoChildren + | _ -> + if !debug then ignore(E.log "rdVis: visit non-il\n"); + cur_rd_dat <- None; + DoChildren + + method vinst i = + if !debug then ignore(E.log "rdVis: before %a, rd_dat_lst is %d long\n" + d_instr i (List.length rd_dat_lst)); + try + cur_rd_dat <- Some(List.hd rd_dat_lst); + rd_dat_lst <- List.tl rd_dat_lst; + DoChildren + with Failure "hd" -> + if !debug then ignore(E.log "rdVis: il rd_dat_lst mismatch\n"); + DoChildren + + method get_cur_iosh () = + match cur_rd_dat with + None -> (match getRDs sid with + None -> None + | Some(_,_,iosh) -> Some iosh) + | Some(_,_,iosh) -> Some iosh + +end + diff --git a/cil/src/ext/sfi.ml b/cil/src/ext/sfi.ml new file mode 100755 index 0000000..9886526 --- /dev/null +++ b/cil/src/ext/sfi.ml @@ -0,0 +1,337 @@ +(* + * + * Copyright (c) 2005, + * George C. Necula + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(** This is a module that inserts runtime checks for memory reads/writes and + * allocations *) + +open Pretty +open Cil +module E = Errormsg +module H = Hashtbl + +let doSfi = ref false +let doSfiReads = ref false +let doSfiWrites = ref true + +(* A number of functions to be skipped *) +let skipFunctions : (string, unit) H.t = H.create 13 +let mustSfiFunction (f: fundec) : bool = + not (H.mem skipFunctions f.svar.vname) + +(** Some functions are known to be allocators *) +type dataLocation = + InResult (* Interesting data is in the return value *) + | InArg of int (* in the nth argument. Starts from 1. *) + | InArgTimesArg of int * int (* (for size) data is the product of two + * arguments *) + | PointedToByArg of int (* pointed to by nth argument *) + +(** Compute the data based on the location and the actual argument list *) +let extractData (dl: dataLocation) (args: exp list) (res: lval option) : exp = + let getArg (n: int) = + try List.nth args (n - 1) (* Args are based at 1 *) + with _ -> E.s (E.bug "Cannot extract argument %d at %a" + n d_loc !currentLoc) + in + match dl with + InResult -> begin + match res with + None -> + E.s (E.bug "Cannot extract InResult data (at %a)" d_loc !currentLoc) + | Some r -> Lval r + end + | InArg n -> getArg n + | InArgTimesArg (n1, n2) -> + let a1 = getArg n1 in + let a2 = getArg n2 in + BinOp(Mult, mkCast ~e:a1 ~newt:longType, + mkCast ~e:a2 ~newt:longType, longType) + | PointedToByArg n -> + let a = getArg n in + Lval (mkMem a NoOffset) + + + +(* for each allocator, where is the length and where is the result *) +let allocators: (string, (dataLocation * dataLocation)) H.t = H.create 13 +let _ = + H.add allocators "malloc" (InArg 1, InResult); + H.add allocators "calloc" (InArgTimesArg (1, 2), InResult); + H.add allocators "realloc" (InArg 2, InResult) + +(* for each deallocator, where is the data being deallocated *) +let deallocators: (string, dataLocation) H.t = H.create 13 +let _= + H.add deallocators "free" (InArg 1); + H.add deallocators "realloc" (InArg 1) + +(* Returns true if the given lvalue offset ends in a bitfield access. *) +let rec is_bitfield lo = match lo with + | NoOffset -> false + | Field(fi,NoOffset) -> not (fi.fbitfield = None) + | Field(_,lo) -> is_bitfield lo + | Index(_,lo) -> is_bitfield lo + +(* Return an expression that evaluates to the address of the given lvalue. + * For most lvalues, this is merely AddrOf(lv). However, for bitfields + * we do some offset gymnastics. + *) +let addr_of_lv (lv: lval) = + let lh, lo = lv in + if is_bitfield lo then begin + (* we figure out what the address would be without the final bitfield + * access, and then we add in the offset of the bitfield from the + * beginning of its enclosing comp *) + let rec split_offset_and_bitfield lo = match lo with + | NoOffset -> failwith "logwrites: impossible" + | Field(fi,NoOffset) -> (NoOffset,fi) + | Field(e,lo) -> let a,b = split_offset_and_bitfield lo in + ((Field(e,a)),b) + | Index(e,lo) -> let a,b = split_offset_and_bitfield lo in + ((Index(e,a)),b) + in + let new_lv_offset, bf = split_offset_and_bitfield lo in + let new_lv = (lh, new_lv_offset) in + let enclosing_type = TComp(bf.fcomp, []) in + let bits_offset, bits_width = + bitsOffset enclosing_type (Field(bf,NoOffset)) in + let bytes_offset = bits_offset / 8 in + let lvPtr = mkCast ~e:(mkAddrOf (new_lv)) ~newt:(charPtrType) in + (BinOp(PlusPI, lvPtr, (integer bytes_offset), ulongType)) + end else + (mkAddrOf (lh,lo)) + + +let mustLogLval (forwrite: bool) (lv: lval) : bool = + match lv with + Var v, off -> (* Inside a variable. We assume the array offsets are fine *) + false + | Mem e, off -> + if forwrite && not !doSfiWrites then + false + else if not forwrite && not !doSfiReads then + false + + (* If this is an lval of function type, we do not log it *) + else if isFunctionType (typeOfLval lv) then + false + else + true + +(* Create prototypes for the logging functions *) +let mkProto (name: string) (args: (string * typ * attributes) list) = + let fdec = emptyFunction name in + fdec.svar.vtype <- TFun(voidType, + Some args, false, []); + fdec + + +let logReads = mkProto "logRead" [ ("addr", voidPtrType, []); + ("what", charPtrType, []); + ("file", charPtrType, []); + ("line", intType, []) ] +let callLogRead (lv: lval) = + let what = Pretty.sprint 80 (d_lval () lv) in + Call(None, + Lval(Var(logReads.svar),NoOffset), + [ addr_of_lv lv; mkString what; mkString !currentLoc.file; + integer !currentLoc.line], !currentLoc ) + +let logWrites = mkProto "logWrite" [ ("addr", voidPtrType, []); + ("what", charPtrType, []); + ("file", charPtrType, []); + ("line", intType, []) ] +let callLogWrite (lv: lval) = + let what = Pretty.sprint 80 (d_lval () lv) in + Call(None, + Lval(Var(logWrites.svar), NoOffset), + [ addr_of_lv lv; mkString what; mkString !currentLoc.file; + integer !currentLoc.line], !currentLoc ) + +let logStackFrame = mkProto "logStackFrame" [ ("func", charPtrType, []) ] +let callLogStack (fname: string) = + Call(None, + Lval(Var(logStackFrame.svar), NoOffset), + [ mkString fname; ], !currentLoc ) + +let logAlloc = mkProto "logAlloc" [ ("addr", voidPtrType, []); + ("size", intType, []); + ("file", charPtrType, []); + ("line", intType, []) ] +let callLogAlloc (szloc: dataLocation) + (resLoc: dataLocation) + (args: exp list) + (res: lval option) = + let sz = extractData szloc args res in + let res = extractData resLoc args res in + Call(None, + Lval(Var(logAlloc.svar), NoOffset), + [ res; sz; mkString !currentLoc.file; + integer !currentLoc.line ], !currentLoc ) + + +let logFree = mkProto "logFree" [ ("addr", voidPtrType, []); + ("file", charPtrType, []); + ("line", intType, []) ] +let callLogFree (dataloc: dataLocation) + (args: exp list) + (res: lval option) = + let data = extractData dataloc args res in + Call(None, + Lval(Var(logFree.svar), NoOffset), + [ data; mkString !currentLoc.file; + integer !currentLoc.line ], !currentLoc ) + +class sfiVisitorClass : Cil.cilVisitor = object (self) + inherit nopCilVisitor + + method vexpr (e: exp) : exp visitAction = + match e with + Lval lv when mustLogLval false lv -> (* A read *) + self#queueInstr [ callLogRead lv ]; + DoChildren + + | _ -> DoChildren + + + method vinst (i: instr) : instr list visitAction = + match i with + Set(lv, e, l) when mustLogLval true lv -> + self#queueInstr [ callLogWrite lv ]; + DoChildren + + | Call(lvo, f, args, l) -> + (* Instrument the write *) + (match lvo with + Some lv when mustLogLval true lv -> + self#queueInstr [ callLogWrite lv ] + | _ -> ()); + (* Do the expressions in the call, and then see if we need to + * instrument the function call *) + ChangeDoChildrenPost + ([i], + (fun il -> + currentLoc := l; + match f with + Lval (Var fv, NoOffset) -> begin + (* Is it an allocator? *) + try + let szloc, resloc = H.find allocators fv.vname in + il @ [callLogAlloc szloc resloc args lvo] + with Not_found -> begin + (* Is it a deallocator? *) + try + let resloc = H.find deallocators fv.vname in + il @ [ callLogFree resloc args lvo ] + with Not_found -> + il + end + end + | _ -> il)) + + | _ -> DoChildren + + method vfunc (fdec: fundec) = + (* Instead a stack log at the start of a function *) + ChangeDoChildrenPost + (fdec, + fun fdec -> + fdec.sbody <- + mkBlock + [ mkStmtOneInstr (callLogStack fdec.svar.vname); + mkStmt (Block fdec.sbody) ]; + fdec) + +end + +let doit (f: file) = + let sfiVisitor = new sfiVisitorClass in + let compileLoc (l: location) = function + ACons("inres", []) -> InResult + | ACons("inarg", [AInt n]) -> InArg n + | ACons("inargxarg", [AInt n1; AInt n2]) -> InArgTimesArg (n1, n2) + | ACons("pointedby", [AInt n]) -> PointedToByArg n + | _ -> E.warn "Invalid location at %a" d_loc l; + InResult + in + iterGlobals f + (fun glob -> + match glob with + GFun(fdec, _) when mustSfiFunction fdec -> + ignore (visitCilFunction sfiVisitor fdec) + | GPragma(Attr("sfiignore", al), l) -> + List.iter + (function AStr fn -> H.add skipFunctions fn () + | _ -> E.warn "Invalid argument in \"sfiignore\" pragma at %a" + d_loc l) + al + + | GPragma(Attr("sfialloc", al), l) -> begin + match al with + AStr fname :: locsz :: locres :: [] -> + H.add allocators fname (compileLoc l locsz, compileLoc l locres) + | _ -> E.warn "Invalid sfialloc pragma at %a" d_loc l + end + + | GPragma(Attr("sfifree", al), l) -> begin + match al with + AStr fname :: locwhat :: [] -> + H.add deallocators fname (compileLoc l locwhat) + | _ -> E.warn "Invalid sfifree pragma at %a" d_loc l + end + + + | _ -> ()); + (* Now add the prototypes for the instrumentation functions *) + f.globals <- + GVarDecl (logReads.svar, locUnknown) :: + GVarDecl (logWrites.svar, locUnknown) :: + GVarDecl (logStackFrame.svar, locUnknown) :: + GVarDecl (logAlloc.svar, locUnknown) :: + GVarDecl (logFree.svar, locUnknown) :: f.globals + + +let feature : featureDescr = + { fd_name = "sfi"; + fd_enabled = doSfi; + fd_description = "instrument memory operations"; + fd_extraopt = [ + "--sfireads", Arg.Set doSfiReads, "SFI for reads"; + "--sfiwrites", Arg.Set doSfiWrites, "SFI for writes"; + ]; + fd_doit = doit; + fd_post_check = true; + } + diff --git a/cil/src/ext/simplemem.ml b/cil/src/ext/simplemem.ml new file mode 100644 index 0000000..1b27815 --- /dev/null +++ b/cil/src/ext/simplemem.ml @@ -0,0 +1,132 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* + * Simplemem: Transform a program so that all memory expressions are + * "simple". Introduce well-typed temporaries to hold intermediate values + * for expressions that would normally involve more than one memory + * reference. + * + * If simplemem succeeds, each lvalue should contain only one Mem() + * constructor. + *) +open Cil + +(* current context: where should we put our temporaries? *) +let thefunc = ref None + +(* build up a list of assignments to temporary variables *) +let assignment_list = ref [] + +(* turn "int a[5][5]" into "int ** temp" *) +let rec array_to_pointer tau = + match unrollType tau with + TArray(dest,_,al) -> TPtr(array_to_pointer dest,al) + | _ -> tau + +(* create a temporary variable in the current function *) +let make_temp tau = + let tau = array_to_pointer tau in + match !thefunc with + Some(fundec) -> makeTempVar fundec ~name:("mem_") tau + | None -> failwith "simplemem: temporary needed outside a function" + +(* separate loffsets into "scalar addition parts" and "memory parts" *) +let rec separate_loffsets lo = + match lo with + NoOffset -> NoOffset, NoOffset + | Field(fi,rest) -> + let s,m = separate_loffsets rest in + Field(fi,s) , m + | Index(_) -> NoOffset, lo + +(* Recursively decompose the lvalue so that what is under a "Mem()" + * constructor is put into a temporary variable. *) +let rec handle_lvalue (lb,lo) = + let s,m = separate_loffsets lo in + match lb with + Var(vi) -> + handle_loffset (lb,s) m + | Mem(Lval(Var(_),NoOffset)) -> + (* special case to avoid generating "tmp = ptr;" *) + handle_loffset (lb,s) m + | Mem(e) -> + begin + let new_vi = make_temp (typeOf e) in + assignment_list := (Set((Var(new_vi),NoOffset),e,!currentLoc)) + :: !assignment_list ; + handle_loffset (Mem(Lval(Var(new_vi),NoOffset)),NoOffset) lo + end +and handle_loffset lv lo = + match lo with + NoOffset -> lv + | Field(f,o) -> handle_loffset (addOffsetLval (Field(f,NoOffset)) lv) o + | Index(exp,o) -> handle_loffset (addOffsetLval (Index(exp,NoOffset)) lv) o + +(* the transformation is implemented as a Visitor *) +class simpleVisitor = object + inherit nopCilVisitor + + method vfunc fundec = (* we must record the current context *) + thefunc := Some(fundec) ; + DoChildren + + method vlval lv = ChangeDoChildrenPost(lv, + (fun lv -> handle_lvalue lv)) + + method unqueueInstr () = + let result = List.rev !assignment_list in + assignment_list := [] ; + result +end + +(* Main entry point: apply the transformation to a file *) +let simplemem (f : file) = + try + visitCilFileSameGlobals (new simpleVisitor) f; + f + with e -> Printf.printf "Exception in Simplemem.simplemem: %s\n" + (Printexc.to_string e) ; raise e + +let feature : featureDescr = + { fd_name = "simpleMem"; + fd_enabled = Cilutil.doSimpleMem; + fd_description = "simplify all memory expressions" ; + fd_extraopt = []; + fd_doit = (function (f: file) -> ignore (simplemem f)) ; + fd_post_check = true; + } diff --git a/cil/src/ext/simplify.ml b/cil/src/ext/simplify.ml new file mode 100755 index 0000000..776d491 --- /dev/null +++ b/cil/src/ext/simplify.ml @@ -0,0 +1,845 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Sumit Gulwani + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* This module simplifies the expressions in a program in the following ways: + +1. All expressions are either + + basic::= + Const _ + Addrof(Var v, NoOffset) + StartOf(Var v, NoOffset) + Lval(Var v, off), where v is a variable whose address is not taken + and off contains only "basic" + + exp::= + basic + Lval(Mem basic, NoOffset) + BinOp(bop, basic, basic) + UnOp(uop, basic) + CastE(t, basic) + + lval ::= + Mem basic, NoOffset + Var v, off, where v is a variable whose address is not taken and off + contains only "basic" + + - all sizeof and alignof are turned into constants + - accesses to variables whose address is taken is turned into "Mem" accesses + - same for accesses to arrays + - all field and index computations are turned into address arithmetic, + including bitfields. + +*) + + +open Pretty +open Cil +module E = Errormsg +module H = Hashtbl + +type taExp = exp (* Three address expression *) +type bExp = exp (* Basic expression *) + +let debug = true + +(* Whether to split structs *) +let splitStructs = ref true + +let onlyVariableBasics = ref false +let noStringConstantsBasics = ref false + +exception BitfieldAccess + +(* Turn an expression into a three address expression (and queue some + * instructions in the process) *) +let rec makeThreeAddress + (setTemp: taExp -> bExp) (* Given an expression save it into a temp and + * return that temp *) + (e: exp) : taExp = + match e with + SizeOf _ | SizeOfE _ | AlignOf _ | AlignOfE _ | SizeOfStr _ -> + constFold true e + | Const _ -> e + | AddrOf (Var _, NoOffset) -> e + | Lval lv -> Lval (simplifyLval setTemp lv) + | BinOp(bo, e1, e2, tres) -> + BinOp(bo, makeBasic setTemp e1, makeBasic setTemp e2, tres) + | UnOp(uo, e1, tres) -> + UnOp(uo, makeBasic setTemp e1, tres) + | CastE(t, e) -> + CastE(t, makeBasic setTemp e) + | AddrOf lv -> begin + match simplifyLval setTemp lv with + Mem a, NoOffset -> a + | _ -> (* This is impossible, because we are taking the address + * of v and simplifyLval should turn it into a Mem, except if the + * sizeof has failed. *) + E.s (bug "Simplify: makeThreeAddress for AddrOf(LV=%a, LVT=%a)" + d_lval lv d_type (typeOfLval lv)) + end + | StartOf lv -> + makeThreeAddress setTemp (AddrOf (addOffsetLval (Index(zero, NoOffset)) + lv)) + +(* Make a basic expression *) +and makeBasic (setTemp: taExp -> bExp) (e: exp) : bExp = + let dump = false (* !currentLoc.line = 395 *) in + if dump then + ignore (E.log "makeBasic %a\n" d_plainexp e); + (* Make it a three address expression first *) + let e' = makeThreeAddress setTemp e in + if dump then + ignore (E.log " e'= %a\n" d_plainexp e); + (* See if it is a basic one *) + match e' with + | Lval (Var _, _) -> e' + | Const _ | AddrOf (Var _, NoOffset) | StartOf (Var _, NoOffset) -> + if !onlyVariableBasics then setTemp e' else e' + | SizeOf _ | SizeOfE _ | AlignOf _ | AlignOfE _ | SizeOfStr _ -> + E.s (bug "Simplify: makeBasic found SizeOf: %a" d_exp e') + + (* We cannot make a function to be Basic, unless it actually is a variable + * already. If this is a function pointer the best we can do is to make + * the address of the function basic *) + | Lval (Mem a, NoOffset) when isFunctionType (typeOf e') -> + if dump then + ignore (E.log " a function type\n"); + let a' = makeBasic setTemp a in + Lval (Mem a', NoOffset) + + | _ -> setTemp e' (* Put it into a temporary otherwise *) + + +and simplifyLval + (setTemp: taExp -> bExp) + (lv: lval) : lval = + (* Add, watching for a zero *) + let add (e1: exp) (e2: exp) = + if isZero e2 then e1 else BinOp(PlusA, e1, e2, !upointType) + in + (* Convert an offset to an integer, and possibly a residual bitfield offset*) + let rec offsetToInt + (t: typ) (* The type of the host *) + (off: offset) : exp * offset = + match off with + NoOffset -> zero, NoOffset + | Field(fi, off') -> begin + let start = + try + let start, _ = bitsOffset t (Field(fi, NoOffset)) in + start + with SizeOfError (whystr, t') -> + E.s (E.bug "%a: Cannot compute sizeof: %s: %a" + d_loc !currentLoc whystr d_type t') + in + if start land 7 <> 0 then begin + (* We have a bitfield *) + assert (off' = NoOffset); + zero, Field(fi, off') + end else begin + let next, restoff = offsetToInt fi.ftype off' in + add (integer (start / 8)) next, restoff + end + end + | Index(ei, off') -> begin + let telem = match unrollType t with + TArray(telem, _, _) -> telem + | _ -> E.s (bug "Simplify: simplifyLval: index on a non-array") + in + let next, restoff = offsetToInt telem off' in + add + (BinOp(Mult, ei, SizeOf telem, !upointType)) + next, + restoff + end + in + let tres = TPtr(typeOfLval lv, []) in + match lv with + Mem a, off -> + let offidx, restoff = offsetToInt (typeOfLval (Mem a, NoOffset)) off in + let a' = + if offidx <> zero then + add (mkCast a !upointType) offidx + else + a + in + let a' = makeBasic setTemp a' in + Mem (mkCast a' tres), restoff + + | Var v, off when v.vaddrof -> (* We are taking this variable's address *) + let offidx, restoff = offsetToInt v.vtype off in + (* We cannot call makeBasic recursively here, so we must do it + * ourselves *) + let a = mkAddrOrStartOf (Var v, NoOffset) in + let a' = + if offidx = zero then a else + add (mkCast a !upointType) (makeBasic setTemp offidx) + in + let a' = setTemp a' in + Mem (mkCast a' tres), restoff + + | Var v, off -> + (Var v, simplifyOffset setTemp off) + + +(* Simplify an offset and make sure it has only three address expressions in + * indices *) +and simplifyOffset (setTemp: taExp -> bExp) = function + NoOffset -> NoOffset + | Field(fi, off) -> Field(fi, simplifyOffset setTemp off) + | Index(ei, off) -> + let ei' = makeBasic setTemp ei in + Index(ei', simplifyOffset setTemp off) + + + + +(** This is a visitor that will turn all expressions into three address code *) +class threeAddressVisitor (fi: fundec) = object (self) + inherit nopCilVisitor + + method private makeTemp (e1: exp) : exp = + let t = makeTempVar fi (typeOf e1) in + (* Add this instruction before the current statement *) + self#queueInstr [Set(var t, e1, !currentLoc)]; + Lval(var t) + + (* We'll ensure that this gets called only for top-level expressions + * inside functions. We must turn them into three address code. *) + method vexpr (e: exp) = + let e' = makeThreeAddress self#makeTemp e in + ChangeTo e' + + + (** We want the argument in calls to be simple variables *) + method vinst (i: instr) = + match i with + Call (someo, f, args, loc) -> + let someo' = + match someo with + Some lv -> Some (simplifyLval self#makeTemp lv) + | _ -> None + in + let f' = makeBasic self#makeTemp f in + let args' = List.map (makeBasic self#makeTemp) args in + ChangeTo [ Call (someo', f', args', loc) ] + | _ -> DoChildren + + (* This method will be called only on top-level "lvals" (those on the + * left of assignments and function calls) *) + method vlval (lv: lval) = + ChangeTo (simplifyLval self#makeTemp lv) +end + +(******************** + Next is an old version of the code that was splitting structs into + * variables. It was not working on variables that are arguments or returns + * of function calls. +(** This is a visitor that splits structured variables into separate + * variables. *) +let isStructType (t: typ): bool = + match unrollType t with + TComp (ci, _) -> ci.cstruct + | _ -> false + +(* Keep track of how we change the variables. For each variable id we keep a + * hash table that maps an offset (a sequence of fieldinfo) into a + * replacement variable. We also keep track of the splittable vars: those + * with structure type but whose address is not take and which do not appear + * as the argument to a Return *) +let splittableVars: (int, unit) H.t = H.create 13 +let replacementVars: (int * offset, varinfo) H.t = H.create 13 + +let findReplacement (fi: fundec) (v: varinfo) (off: offset) : varinfo = + try + H.find replacementVars (v.vid, off) + with Not_found -> begin + let t = typeOfLval (Var v, off) in + (* make a name for this variable *) + let rec mkName = function + | Field(fi, off) -> "_" ^ fi.fname ^ mkName off + | _ -> "" + in + let v' = makeTempVar fi ~name:(v.vname ^ mkName off ^ "_") t in + H.add replacementVars (v.vid, off) v'; + if debug then + ignore (E.log "Simplify: %s (%a) replace %a with %s\n" + fi.svar.vname + d_loc !currentLoc + d_lval (Var v, off) + v'.vname); + v' + end + + (* Now separate the offset into a sequence of field accesses and the + * rest of the offset *) +let rec separateOffset (off: offset): offset * offset = + match off with + NoOffset -> NoOffset, NoOffset + | Field(fi, off') when fi.fcomp.cstruct -> + let off1, off2 = separateOffset off' in + Field(fi, off1), off2 + | _ -> NoOffset, off + + +class splitStructVisitor (fi: fundec) = object (self) + inherit nopCilVisitor + + method vlval (lv: lval) = + match lv with + Var v, off when H.mem splittableVars v.vid -> + (* The type of this lval better not be a struct *) + if isStructType (typeOfLval lv) then + E.s (unimp "Simplify: found lval of struct type %a : %a\n" + d_lval lv d_type (typeOfLval lv)); + let off1, restoff = separateOffset off in + let lv' = + if off1 <> NoOffset then begin + (* This is a splittable variable and we have an offset that makes + * it a scalar. Find the replacement variable for this *) + let v' = findReplacement fi v off1 in + if restoff = NoOffset then + Var v', NoOffset + else (* We have some more stuff. Use Mem *) + Mem (mkAddrOrStartOf (Var v', NoOffset)), restoff + end else begin (* off1 = NoOffset *) + if restoff = NoOffset then + E.s (bug "Simplify: splitStructVisitor:lval") + else + simplifyLval + (fun e1 -> + let t = makeTempVar fi (typeOf e1) in + (* Add this instruction before the current statement *) + self#queueInstr [Set(var t, e1, !currentLoc)]; + Lval(var t)) + (Mem (mkAddrOrStartOf (Var v, NoOffset)), restoff) + end + in + ChangeTo lv' + + | _ -> DoChildren + + method vinst (i: instr) = + (* Accumulate to the list of instructions a number of assignments of + * non-splittable lvalues *) + let rec accAssignment (ci: compinfo) (dest: lval) (what: lval) + (acc: instr list) : instr list = + List.fold_left + (fun acc f -> + let dest' = addOffsetLval (Field(f, NoOffset)) dest in + let what' = addOffsetLval (Field(f, NoOffset)) what in + match unrollType f.ftype with + TComp(ci, _) when ci.cstruct -> + accAssignment ci dest' what' acc + | TArray _ -> (* We must copy the array *) + (Set((Mem (AddrOf dest'), NoOffset), + Lval (Mem (AddrOf what'), NoOffset), !currentLoc)) :: acc + | _ -> (* If the type of f is not a struct then leave this alone *) + (Set(dest', Lval what', !currentLoc)) :: acc) + acc + ci.cfields + in + let doAssignment (ci: compinfo) (dest: lval) (what: lval) : instr list = + let il' = accAssignment ci dest what [] in + List.concat (List.map (visitCilInstr (self :> cilVisitor)) il') + in + match i with + Set(((Var v, off) as lv), what, _) when H.mem splittableVars v.vid -> + let off1, restoff = separateOffset off in + if restoff <> NoOffset then (* This means that we are only assigning + * part of a replacement variable. Leave + * this alone because the vlval will take + * care of it *) + DoChildren + else begin + (* The type of the replacement has to be a structure *) + match unrollType (typeOfLval lv) with + TComp (ci, _) when ci.cstruct -> + (* The assigned thing better be an lvalue *) + let whatlv = + match what with + Lval lv -> lv + | _ -> E.s (unimp "Simplify: assigned struct is not lval") + in + ChangeTo (doAssignment ci (Var v, off) whatlv) + + | _ -> (* vlval will take care of it *) + DoChildren + end + + | Set(dest, Lval (Var v, off), _) when H.mem splittableVars v.vid -> + let off1, restoff = separateOffset off in + if restoff <> NoOffset then (* vlval will do this *) + DoChildren + else begin + (* The type of the replacement has to be a structure *) + match unrollType (typeOfLval dest) with + TComp (ci, _) when ci.cstruct -> + ChangeTo (doAssignment ci dest (Var v, off)) + + | _ -> (* vlval will take care of it *) + DoChildren + end + + | _ -> DoChildren + +end +*) + +(* Whether to split the arguments of functions *) +let splitArguments = true + +(* Whether we try to do the splitting all in one pass. The advantage is that + * it is faster and it generates nicer names *) +let lu = locUnknown + +(* Go over the code and split some temporary variables of stucture type into + * several separate variables. The hope is that the compiler will have an + * easier time to do standard optimizations with the resulting scalars *) +(* Unfortunately, implementing this turns out to be more complicated than I + * thought *) + +(** Iterate over the fields of a structured type. Returns the empty list if + * no splits. The offsets are in order in which they appear in the structure + * type. Along with the offset we pass a string that identifies the + * meta-component, and the type of that component. *) +let rec foldRightStructFields + (doit: offset -> string -> typ -> 'a) (* Invoked on non-struct fields *) + (off: offset) + (post: 'a list) (** A suffix to what you compute *) + (fields: fieldinfo list) : 'a list = + List.fold_right + (fun f post -> + let off' = addOffset (Field(f, NoOffset)) off in + match unrollType f.ftype with + TComp (comp, _) when comp.cstruct -> (* struct type: recurse *) + foldRightStructFields doit off' post comp.cfields + | _ -> + (doit off' f.fname f.ftype) :: post) + fields + post + + +let rec foldStructFields + (t: typ) + (doit: offset -> string -> typ -> 'a) + : 'a list = + match unrollType t with + TComp (comp, _) when comp.cstruct -> + foldRightStructFields doit NoOffset [] comp.cfields + | _ -> [] + + +(* Map a variable name to a list of component variables, along with the + * accessor offset. The fields are in the order in which they appear in the + * structure. *) +let newvars : (string, (offset * varinfo) list) H.t = H.create 13 + +(* Split a variable and return the replacements, in the proper order. If this + * variable is not split, then return just the variable. *) +let splitOneVar (v: varinfo) + (mknewvar: string -> typ -> varinfo) : varinfo list = + try + (* See if we have already split it *) + List.map snd (H.find newvars v.vname) + with Not_found -> begin + let vars: (offset * varinfo) list = + foldStructFields v.vtype + (fun off n t -> (* make a new one *) + let newname = v.vname ^ "_" ^ n in + let v'= mknewvar newname t in + (off, v')) + in + if vars = [] then + [ v ] + else begin + (* Now remember the newly created vars *) + H.add newvars v.vname vars; + List.map snd vars (* Return just the vars *) + end + end + + +(* A visitor that finds all locals that appear in a call or have their + * address taken *) +let dontSplitLocals : (string, bool) H.t = H.create 111 +class findVarsCantSplitClass : cilVisitor = object (self) + inherit nopCilVisitor + + (* expressions, to see the address being taken *) + method vexpr (e: exp) : exp visitAction = + match e with + AddrOf (Var v, NoOffset) -> + H.add dontSplitLocals v.vname true; SkipChildren + (* See if we take the address of the "_ms" field in a variable *) + | _ -> DoChildren + + + (* variables involved in call instructions *) + method vinst (i: instr) : instr list visitAction = + match i with + Call (res, f, args, _) -> + (match res with + Some (Var v, NoOffset) -> H.add dontSplitLocals v.vname true + | _ -> ()); + if not splitArguments then + List.iter (fun a -> + match a with + Lval (Var v, NoOffset) -> H.add dontSplitLocals v.vname true + | _ -> ()) args; + (* Now continue the visit *) + DoChildren + + | _ -> DoChildren + + (* Variables used in return should not be split *) + method vstmt (s: stmt) : stmt visitAction = + match s.skind with + Return (Some (Lval (Var v, NoOffset)), _) -> + H.add dontSplitLocals v.vname true; DoChildren + | Return (Some e, _) -> + DoChildren + | _ -> DoChildren + + method vtype t = SkipChildren + +end +let findVarsCantSplit = new findVarsCantSplitClass + +let isVar lv = + match lv with + (Var v, NoOffset) -> true + | _ -> false + + +class splitVarVisitorClass(func:fundec option) : cilVisitor = object (self) + inherit nopCilVisitor + + method private makeTemp (e1: exp) : exp = + let fi:fundec = match func with + Some f -> f + | None -> + E.s (bug "You can't create a temporary if you're not in a function.") + in + let t = makeTempVar fi (typeOf e1) in + (* Add this instruction before the current statement *) + self#queueInstr [Set(var t, e1, !currentLoc)]; + Lval(var t) + + + (* We must process the function types *) + method vtype t = + (* We invoke the visitor first and then we fix it *) + let postProcessFunType (t: typ) : typ = + match t with + TFun(rt, Some params, isva, a) -> + let rec loopParams = function + [] -> [] + | ((pn, pt, pa) :: rest) as params -> + let rest' = loopParams rest in + let res: (string * typ * attributes) list = + foldStructFields pt + (fun off n t -> + (* Careful with no-name parameters, or we end up with + * many parameters named _p ! *) + ((if pn <> "" then pn ^ n else ""), t, pa)) + in + if res = [] then (* Not a fat *) + if rest' == rest then + params (* No change at all. Try not to reallocate so that + * the visitor does not allocate. *) + else + (pn, pt, pa) :: rest' + else (* Some change *) + res @ rest' + in + let params' = loopParams params in + if params == params' then + t + else + TFun(rt, Some params', isva, a) + + | t -> t + in + if splitArguments then + ChangeDoChildrenPost(t, postProcessFunType) + else + SkipChildren + + (* Whenever we see a variable with a field access we try to replace it + * by its components *) + method vlval ((b, off) : lval) : lval visitAction = + try + match b, off with + Var v, (Field _ as off) -> + (* See if this variable has some splits.Might throw Not_found *) + let splits = H.find newvars v.vname in + (* Now find among the splits one that matches this offset. And + * return the remaining offset *) + let rec find = function + [] -> + E.s (E.bug "Cannot find component %a of %s\n" + (d_offset nil) off v.vname) + | (splitoff, splitvar) :: restsplits -> + let rec matches = function + Field(f1, rest1), Field(f2, rest2) + when f1.fname = f2.fname -> + matches (rest1, rest2) + | off, NoOffset -> + (* We found a match *) + (Var splitvar, off) + | NoOffset, restoff -> + ignore (warn "Found aggregate lval %a\n" + d_lval (b, off)); + find restsplits + + | _, _ -> (* We did not match this one; go on *) + find restsplits + in + matches (off, splitoff) + in + ChangeTo (find splits) + | _ -> DoChildren + with Not_found -> DoChildren + + (* Sometimes we pass the variable as a whole to a function or we + * assign it to something *) + method vinst (i: instr) : instr list visitAction = + match i with + (* Split into several instructions and then do children inside + * the rhs. Howver, v might appear in the rhs and if we + * duplicate the instruction we might get bad + * results. (e.g. test/small1/simplify_Structs2.c). So first copy + * the rhs to temp variables, then to v. + * + * Optimization: if the rhs is a variable, skip the temporary vars. + * Either the rhs = lhs, in which case this is all a nop, or it's not, + * in which case the rhs and lhs don't overlap.*) + + Set ((Var v, NoOffset), Lval lv, l) when H.mem newvars v.vname -> begin + let needTemps = not (isVar lv) in + let vars4v = H.find newvars v.vname in + if vars4v = [] then E.s (errorLoc l "No fields in split struct"); + ChangeTo + (List.map + (fun (off, newv) -> + let lv' = + visitCilLval (self :> cilVisitor) + (addOffsetLval off lv) in + (* makeTemp creates a temp var and puts (Lval lv') in it, + before any instructions in this ChangeTo list are handled.*) + let lv_tmp = if needTemps then + self#makeTemp (Lval lv') + else + (Lval lv') + in + Set((Var newv, NoOffset), lv_tmp, l)) + vars4v) + end + + | Set (lv, Lval (Var v, NoOffset), l) when H.mem newvars v.vname -> begin + (* Split->NonSplit assignment. no overlap between lhs and rhs + is possible*) + let vars4v = H.find newvars v.vname in + if vars4v = [] then E.s (errorLoc l "No fields in split struct"); + ChangeTo + (List.map + (fun (off, newv) -> + let lv' = + visitCilLval (self :> cilVisitor) + (addOffsetLval off lv) in + Set(lv', Lval (Var newv, NoOffset), l)) + vars4v) + end + + (* Split all function arguments in calls *) + | Call (ret, f, args, l) when splitArguments -> + (* Visit the children first and then see if we must change the + * arguments *) + let finishArgs = function + [Call (ret', f', args', l')] as i' -> + let mustChange = ref false in + let newargs = + (* Look for opportunities to split arguments. If we can + * split, we must split the original argument (in args). + * Otherwise, we use the result of processing children + * (in args'). *) + List.fold_right2 + (fun a a' acc -> + match a with + Lval (Var v, NoOffset) when H.mem newvars v.vname -> + begin + mustChange := true; + (List.map + (fun (_, newv) -> + Lval (Var newv, NoOffset)) + (H.find newvars v.vname)) + @ acc + end + | Lval lv -> begin + let newargs = + foldStructFields (typeOfLval lv) + (fun off n t -> + let lv' = addOffsetLval off lv in + Lval lv') in + if newargs = [] then + a' :: acc (* not a split var *) + else begin + mustChange := true; + newargs @ acc + end + end + | _ -> (* only lvals are split, right? *) + a' :: acc) + args args' + [] + in + if !mustChange then + [Call (ret', f', newargs, l')] + else + i' + | _ -> E.s (E.bug "splitVarVisitorClass: expecting call") + in + ChangeDoChildrenPost ([i], finishArgs) + + | _ -> DoChildren + + + method vfunc (func: fundec) : fundec visitAction = + H.clear newvars; + H.clear dontSplitLocals; + (* Visit the type of the function itself *) + if splitArguments then + func.svar.vtype <- visitCilType (self :> cilVisitor) func.svar.vtype; + + (* Go over the block and find the candidates *) + ignore (visitCilBlock findVarsCantSplit func.sbody); + + (* Now go over the formals and create the splits *) + if splitArguments then begin + (* Split all formals because we will split all arguments in function + * types *) + let newformals = + List.fold_right + (fun form acc -> + (* Process the type first *) + form.vtype <- + visitCilType (self : #cilVisitor :> cilVisitor) form.vtype; + let form' = + splitOneVar form + (fun s t -> makeLocalVar func ~insert:false s t) + in + (* Now it is a good time to check if we actually can split this + * one *) + if List.length form' > 1 && + H.mem dontSplitLocals form.vname then + ignore (warn "boxsplit: can't split formal \"%s\" in %s. Make sure you never take the address of a formal.\n" + form.vname func.svar.vname); + form' @ acc) + func.sformals [] + in + (* Now make sure we fix the type. *) + setFormals func newformals + end; + (* Now go over the locals and create the splits *) + List.iter + (fun l -> + (* Process the type of the local *) + l.vtype <- visitCilType (self :> cilVisitor) l.vtype; + (* Now see if we must split it *) + if not (H.mem dontSplitLocals l.vname) then begin + ignore (splitOneVar l (fun s t -> makeTempVar func ~name:s t)) + end) + func.slocals; + (* Now visit the body and change references to these variables *) + ignore (visitCilBlock (self :> cilVisitor) func.sbody); + H.clear newvars; + H.clear dontSplitLocals; + SkipChildren (* We are done with this function *) + + (* Try to catch the occurrences of the variable in a sizeof expression *) + method vexpr (e: exp) = + match e with + | SizeOfE (Lval(Var v, NoOffset)) -> begin + try + let splits = H.find newvars v.vname in + (* We cound here on no padding between the elements ! *) + ChangeTo + (List.fold_left + (fun acc (_, thisv) -> + BinOp(PlusA, SizeOfE(Lval(Var thisv, NoOffset)), + acc, uintType)) + zero + splits) + with Not_found -> DoChildren + end + | _ -> DoChildren +end + +let doGlobal = function + GFun(fi, _) -> + (* Visit the body and change all expressions into three address code *) + let v = new threeAddressVisitor fi in + fi.sbody <- visitCilBlock v fi.sbody; + if !splitStructs then begin + H.clear dontSplitLocals; + let splitVarVisitor = new splitVarVisitorClass (Some fi) in + ignore (visitCilFunction splitVarVisitor fi); + end + | GVarDecl(vi, _) when isFunctionType vi.vtype -> + (* we might need to split the args/return value in the function type. *) + if !splitStructs then begin + H.clear dontSplitLocals; + let splitVarVisitor = new splitVarVisitorClass None in + ignore (visitCilVarDecl splitVarVisitor vi); + end + | _ -> () + +let feature : featureDescr = + { fd_name = "simplify"; + fd_enabled = ref false; + fd_description = "compiles CIL to 3-address code"; + fd_extraopt = [ + ("--no-split-structs", Arg.Unit (fun _ -> splitStructs := false), + "do not split structured variables"); + ]; + fd_doit = (function f -> iterGlobals f doGlobal); + fd_post_check = true; +} + diff --git a/cil/src/ext/ssa.ml b/cil/src/ext/ssa.ml new file mode 100644 index 0000000..942c92b --- /dev/null +++ b/cil/src/ext/ssa.ml @@ -0,0 +1,696 @@ +module B=Bitmap +module E = Errormsg + +open Cil +open Pretty + +let debug = false + +(* Globalsread, Globalswritten should be closed under call graph *) + +module StringOrder = + struct + type t = string + let compare s1 s2 = + if s1 = s2 then 0 else + if s1 < s2 then -1 else 1 + end + +module StringSet = Set.Make (StringOrder) + +module IntOrder = + struct + type t = int + let compare i1 i2 = + if i1 = i2 then 0 else + if i1 < i2 then -1 else 1 + end + +module IntSet = Set.Make (IntOrder) + + +type cfgInfo = { + name: string; (* The function name *) + start : int; + size : int; + blocks: cfgBlock array; (** Dominating blocks must come first *) + successors: int list array; (* block indices *) + predecessors: int list array; + mutable nrRegs: int; + mutable regToVarinfo: varinfo array; (** Map register IDs to varinfo *) + } + +(** A block corresponds to a statement *) +and cfgBlock = { + bstmt: Cil.stmt; + + (* We abstract the statement as a list of def/use instructions *) + instrlist: instruction list; + mutable livevars: (reg * int) list; + (** For each variable ID that is live at the start of the block, the + * block whose definition reaches this point. If that block is the same + * as the current one, then the variable is a phi variable *) + mutable reachable: bool; + } + +and instruction = (reg list * reg list) + (* lhs variables, variables on rhs. *) + + +and reg = int + +type idomInfo = int array (* immediate dominator *) + +and dfInfo = (int list) array (* dominance frontier *) + +and oneSccInfo = { + nodes: int list; + headers: int list; + backEdges: (int*int) list; + } + +and sccInfo = oneSccInfo list + +(* Muchnick's Domin_Fast, 7.16 *) + +let compute_idom (flowgraph: cfgInfo): idomInfo = + let start = flowgraph.start in + let size = flowgraph.size in + let successors = flowgraph.successors in + let predecessors = flowgraph.predecessors in + let n0 = size in (* a new node (not in the flowgraph) *) + let idom = Array.make size (-1) in (* Make an array of immediate dominators *) + let nnodes = size + 1 in + let nodeSet = B.init nnodes (fun i -> true) in + + let ndfs = Array.create nnodes 0 in (* mapping from depth-first + * number to nodes. DForder + * starts at 1, with 0 used as + * an invalid entry *) + let parent = Array.create nnodes 0 in (* the parent in depth-first + * spanning tree *) + + (* A semidominator of w is the node v with the minimal DForder such + * that there is a path from v to w containing only nodes with the + * DForder larger than w. *) + let sdno = Array.create nnodes 0 in (* depth-first number of + * semidominator *) + + (* The set of nodes whose + * semidominator is ndfs(i) *) + let bucket = Array.init nnodes (fun _ -> B.cloneEmpty nodeSet) in + + (* The functions link and eval maintain a forest within the + * depth-first spanning tree. Ancestor is n0 is the node is a root in + * the forest. Label(v) is the node in the ancestor chain with the + * smallest depth-first number of its semidominator. Child and Size + * are used to keep the trees in the forest balanced *) + let ancestor = Array.create nnodes 0 in + let label = Array.create nnodes 0 in + let child = Array.create nnodes 0 in + let size = Array.create nnodes 0 in + + + let n = ref 0 in (* depth-first scan and numbering. + * Initialize data structures. *) + ancestor.(n0) <- n0; + label.(n0) <- n0; + let rec depthFirstSearchDom v = + incr n; + sdno.(v) <- !n; + ndfs.(!n) <- v; label.(v) <- v; + ancestor.(v) <- n0; (* All nodes are roots initially *) + child.(v) <- n0; size.(v) <- 1; + List.iter + (fun w -> + if sdno.(w) = 0 then begin + parent.(w) <- v; depthFirstSearchDom w + end) + successors.(v); + in + (* Determine the ancestor of v whose semidominator has the the minimal + * DFnumber. In the process, compress the paths in the forest. *) + let eval v = + let rec compress v = + if ancestor.(ancestor.(v)) <> n0 then + begin + compress ancestor.(v); + if sdno.(label.(ancestor.(v))) < sdno.(label.(v)) then + label.(v) <- label.(ancestor.(v)); + ancestor.(v) <- ancestor.(ancestor.(v)) + end + in + if ancestor.(v) = n0 then label.(v) + else begin + compress v; + if sdno.(label.(ancestor.(v))) >= sdno.(label.(v)) then + label.(v) + else label.(ancestor.(v)) + end + in + + let link v w = + let s = ref w in + while sdno.(label.(w)) < sdno.(label.(child.(!s))) do + if size.(!s) + size.(child.(child.(!s))) >= 2* size.(child.(!s)) then + (ancestor.(child.(!s)) <- !s; + child.(!s) <- child.(child.(!s))) + else + (size.(child.(!s)) <- size.(!s); + ancestor.(!s) <- child.(!s); s := child.(!s)); + done; + label.(!s) <- label.(w); + size.(v) <- size.(v) + size.(w); + if size.(v) < 2 * size.(w) then begin + let tmp = !s in + s := child.(v); + child.(v) <- tmp; + end; + while !s <> n0 do + ancestor.(!s) <- v; + s := child.(!s); + done; + in + (* Start now *) + depthFirstSearchDom start; + for i = !n downto 2 do + let w = ndfs.(i) in + List.iter (fun v -> + let u = eval v in + if sdno.(u) < sdno.(w) then sdno.(w) <- sdno.(u);) + predecessors.(w); + B.set bucket.(ndfs.(sdno.(w))) w true; + link parent.(w) w; + while not (B.empty bucket.(parent.(w))) do + let v = + match B.toList bucket.(parent.(w)) with + x :: _ -> x + | [] -> ignore(print_string "Error in dominfast");0 in + B.set bucket.(parent.(w)) v false; + let u = eval v in + idom.(v) <- if sdno.(u) < sdno.(v) then u else parent.(w); + done; + done; + + for i=2 to !n do + let w = ndfs.(i) in + if idom.(w) <> ndfs.(sdno.(w)) then begin + let newDom = idom.(idom.(w)) in + idom.(w) <- newDom; + end + done; + idom + + + + + +let dominance_frontier (flowgraph: cfgInfo) : dfInfo = + let idom = compute_idom flowgraph in + let size = flowgraph.size in + let children = Array.create size [] in + for i = 0 to size - 1 do + if (idom.(i) != -1) then children.(idom.(i)) <- i :: children.(idom.(i)); + done; + + let size = flowgraph.size in + let start = flowgraph.start in + let successors = flowgraph.successors in + + let df = Array.create size [] in + (* Compute the dominance frontier *) + + let bottom = Array.make size true in (* bottom of the dominator tree *) + for i = 0 to size - 1 do + if (i != start) && idom.(i) <> -1 then bottom.(idom.(i)) <- false; + done; + + let processed = Array.make size false in (* to record the nodes added to work_list *) + let workList = ref ([]) in (* to iterate in a bottom-up traversal of the dominator tree *) + for i = 0 to size - 1 do + if (bottom.(i)) then workList := i :: !workList; + done; + while (!workList != []) do + let x = List.hd !workList in + let update y = if idom.(y) <> x then df.(x) <- y::df.(x) in + (* compute local component *) + +(* We use whichPred instead of whichSucc because ultimately this info is + * needed by control dependence dag which is constructed from REVERSE + * dominance frontier *) + List.iter (fun succ -> update succ) successors.(x); + (* add on up component *) + List.iter (fun z -> List.iter (fun y -> update y) df.(z)) children.(x); + processed.(x) <- true; + workList := List.tl !workList; + if (x != start) then begin + let i = idom.(x) in + if i <> -1 && + (List.for_all (fun child -> processed.(child)) children.(i)) then workList := i :: !workList; + end; + done; + df + + +(* Computes for each register, the set of nodes that need a phi definition + * for the register *) + +let add_phi_functions_info (flowgraph: cfgInfo) : unit = + let df = dominance_frontier flowgraph in + let size = flowgraph.size in + let nrRegs = flowgraph.nrRegs in + + + let defs = Array.init size (fun i -> B.init nrRegs (fun j -> false)) in + for i = 0 to size-1 do + List.iter + (fun (lhs,rhs) -> + List.iter (fun (r: reg) -> B.set defs.(i) r true) lhs; + ) + flowgraph.blocks.(i).instrlist + done; + let iterCount = ref 0 in + let hasAlready = Array.create size 0 in + let work = Array.create size 0 in + let w = ref ([]) in + let dfPlus = Array.init nrRegs ( + fun i -> + let defIn = B.make size in + for j = 0 to size - 1 do + if B.get defs.(j) i then B.set defIn j true + done; + let res = ref [] in + incr iterCount; + B.iter (fun x -> work.(x) <- !iterCount; w := x :: !w;) defIn; + while (!w != []) do + let x = List.hd !w in + w := List.tl !w; + List.iter (fun y -> + if (hasAlready.(y) < !iterCount) then begin + res := y :: !res; + hasAlready.(y) <- !iterCount; + if (work.(y) < !iterCount) then begin + work.(y) <- !iterCount; + w := y :: !w; + end; + end; + ) df.(x) + done; + (* res := List.filter (fun blkId -> B.get liveIn.(blkId) i) !res; *) + !res + ) in + let result = Array.create size ([]) in + for i = 0 to nrRegs - 1 do + List.iter (fun node -> result.(node) <- i::result.(node);) dfPlus.(i) + done; +(* result contains for each node, the list of variables that need phi + * definition *) + for i = 0 to size-1 do + flowgraph.blocks.(i).livevars <- + List.map (fun r -> (r, i)) result.(i); + done + + + +(* add dominating definitions info *) + +let add_dom_def_info (f: cfgInfo): unit = + let blocks = f.blocks in + let start = f.start in + let size = f.size in + let nrRegs = f.nrRegs in + + let idom = compute_idom f in + let children = Array.create size [] in + for i = 0 to size - 1 do + if (idom.(i) != -1) then children.(idom.(i)) <- i :: children.(idom.(i)); + done; + + if debug then begin + ignore (E.log "Immediate dominators\n"); + for i = 0 to size - 1 do + ignore (E.log " block %d: idom=%d, children=%a\n" + i idom.(i) + (docList num) children.(i)); + done + end; + + (* For each variable, maintain a stack of blocks that define it. When you + * process a block, the top of the stack is the closest dominator that + * defines the variable *) + let s = Array.make nrRegs ([start]) in + + (* Search top-down in the idom tree *) + let rec search (x: int): unit = (* x is a graph node *) + (* Push the current block for the phi variables *) + List.iter + (fun ((r: reg), dr) -> + if x = dr then s.(r) <- x::s.(r)) + blocks.(x).livevars; + + (* Clear livevars *) + blocks.(x).livevars <- []; + + (* Compute livevars *) + for i = 0 to nrRegs-1 do + match s.(i) with + | [] -> assert false + | fst :: _ -> + blocks.(x).livevars <- (i, fst) :: blocks.(x).livevars + done; + + + (* Update s for the children *) + List.iter + (fun (lhs,rhs) -> + List.iter (fun (lreg: reg) -> s.(lreg) <- x::s.(lreg) ) lhs; + ) + blocks.(x).instrlist; + + + (* Go and do the children *) + List.iter search children.(x); + + (* Then we pop x, whenever it is on top of a stack *) + Array.iteri + (fun i istack -> + let rec dropX = function + [] -> [] + | x' :: rest when x = x' -> dropX rest + | l -> l + in + s.(i) <- dropX istack) + s; + in + search(start) + + + +let prune_cfg (f: cfgInfo): cfgInfo = + let size = f.size in + if size = 0 then f else + let reachable = Array.make size false in + let worklist = ref([f.start]) in + while (!worklist != []) do + let h = List.hd !worklist in + worklist := List.tl !worklist; + reachable.(h) <- true; + List.iter (fun s -> if (reachable.(s) = false) then worklist := s::!worklist; + ) f.successors.(h); + done; +(* + let dummyblock = { bstmt = mkEmptyStmt (); + instrlist = []; + livevars = [] } + in +*) + let successors = Array.init size (fun i -> List.filter (fun s -> reachable.(s)) f.successors.(i)) in + let predecessors = Array.init size (fun i -> List.filter (fun s -> reachable.(s)) f.predecessors.(i)) in + Array.iteri (fun i b -> b.reachable <- reachable.(i)) f.blocks; + let result: cfgInfo = + { name = f.name; + start = f.start; + size = f.size; + successors = successors; + predecessors = predecessors; + blocks = f.blocks; + nrRegs = f.nrRegs; + regToVarinfo = f.regToVarinfo; + } + in + result + + +let add_ssa_info (f: cfgInfo): unit = + let f = prune_cfg f in + let d_reg () (r: int) = + dprintf "%s(%d)" f.regToVarinfo.(r).vname r + in + if debug then begin + ignore (E.log "Doing SSA for %s. Initial data:\n" f.name); + Array.iteri (fun i b -> + ignore (E.log " block %d:\n succs=@[%a@]\n preds=@[%a@]\n instr=@[%a@]\n" + i + (docList num) f.successors.(i) + (docList num) f.predecessors.(i) + (docList ~sep:line (fun (lhs, rhs) -> + dprintf "%a := @[%a@]" + (docList (d_reg ())) lhs (docList (d_reg ())) rhs)) + b.instrlist)) + f.blocks; + end; + + add_phi_functions_info f; + add_dom_def_info f; + + if debug then begin + ignore (E.log "After SSA\n"); + Array.iter (fun b -> + ignore (E.log " block %d livevars: @[%a@]\n" + b.bstmt.sid + (docList (fun (i, fst) -> + dprintf "%a def at %d" d_reg i fst)) + b.livevars)) + f.blocks; + end + + +let set2list s = + let result = ref([]) in + IntSet.iter (fun element -> result := element::!result) s; + !result + + + + +let preorderDAG (nrNodes: int) (successors: (int list) array): int list = + let processed = Array.make nrNodes false in + let revResult = ref ([]) in + let predecessorsSet = Array.make nrNodes (IntSet.empty) in + for i = 0 to nrNodes -1 do + List.iter (fun s -> predecessorsSet.(s) <- IntSet.add i predecessorsSet.(s)) successors.(i); + done; + let predecessors = Array.init nrNodes (fun i -> set2list predecessorsSet.(i)) in + let workList = ref([]) in + for i = 0 to nrNodes - 1 do + if (predecessors.(i) = []) then workList := i::!workList; + done; + while (!workList != []) do + let x = List.hd !workList in + workList := List.tl !workList; + revResult := x::!revResult; + processed.(x) <- true; + List.iter (fun s -> + if (List.for_all (fun p -> processed.(p)) predecessors.(s)) then + workList := s::!workList; + ) successors.(x); + done; + List.rev !revResult + + +(* Muchnick Fig 7.12 *) +(* takes an SCC description as an input and returns prepares the appropriate SCC *) +let preorder (nrNodes: int) (successors: (int list) array) (r: int): oneSccInfo = + if debug then begin + ignore (E.log "Inside preorder \n"); + for i = 0 to nrNodes - 1 do + ignore (E.log "succ(%d) = %a" i (docList (fun i -> num i)) successors.(i)); + done; + end; + let i = ref(0) in + let j = ref(0) in + let pre = Array.make nrNodes (-1) in + let post = Array.make nrNodes (-1) in + let visit = Array.make nrNodes (false) in + let backEdges = ref ([]) in + let headers = ref(IntSet.empty) in + let rec depth_first_search_pp (x:int) = + visit.(x) <- true; + pre.(x) <- !j; + incr j; + List.iter (fun (y:int) -> + if (not visit.(y)) then + (depth_first_search_pp y) + else + if (post.(y) = -1) then begin + backEdges := (x,y)::!backEdges; + headers := IntSet.add y !headers; + end; + ) successors.(x); + post.(x) <- !i; + incr i; + in + depth_first_search_pp r; + let nodes = Array.make nrNodes (-1) in + for y = 0 to nrNodes - 1 do + if (pre.(y) != -1) then nodes.(pre.(y)) <- y; + done; + let nodeList = List.filter (fun i -> (i != -1)) (Array.to_list nodes) in + let result = { headers = set2list !headers; backEdges = !backEdges; nodes = nodeList; } in + result + + +exception Finished + + +let strong_components (f: cfgInfo) (debug: bool) = + let size = f.size in + let parent = Array.make size (-1) in + let color = Array.make size (-1) in + let finish = Array.make size (-1) in + let root = Array.make size (-1) in + +(* returns a list of SCC. Each SCC is a tuple of SCC root and SCC nodes *) + let dfs (successors: (int list) array) (order: int array) = + let time = ref(-1) in + let rec dfs_visit u = + color.(u) <- 1; + incr time; + (* d.(u) <- time; *) + List.iter (fun v -> + if color.(v) = 0 then (parent.(v) <- u; dfs_visit v) + ) successors.(u); + color.(u) <- 2; + incr time; + finish.(u) <- !time + in + for u = 0 to size - 1 do + color.(u) <- 0; (* white = 0, gray = 1, black = 2 *) + parent.(u) <- -1; (* nil = -1 *) + root.(u) <- 0; (* Is u a root? *) + done; + time := 0; + Array.iter (fun u -> + if (color.(u) = 0) then begin + root.(u) <- 1; + dfs_visit u; + end; + ) order; + in + + let simpleOrder = Array.init size (fun i -> i) in + dfs f.successors simpleOrder; + Array.sort (fun i j -> if (finish.(i) > finish.(j)) then -1 else 1) simpleOrder; + + dfs f.predecessors simpleOrder; +(* SCCs have been computed. (The trees represented by non-null parent edges + * represent the SCCS. We call the black nodes as the roots). Now put the + * result in the ouput format *) + let allScc = ref([]) in + for u = 0 to size - 1 do + if root.(u) = 1 then begin + let sccNodes = ref(IntSet.empty) in + let workList = ref([u]) in + while (!workList != []) do + let h=List.hd !workList in + workList := List.tl !workList; + sccNodes := IntSet.add h !sccNodes; + List.iter (fun s -> if parent.(s)=h then workList := s::!workList;) f.predecessors.(h); + done; + allScc := (u,!sccNodes)::!allScc; + if (debug) then begin + ignore (E.log "Got an SCC with root %d and nodes %a" u (docList num) (set2list !sccNodes)); + end; + end; + done; + !allScc + + +let stronglyConnectedComponents (f: cfgInfo) (debug: bool): sccInfo = + let size = f.size in + if (debug) then begin + ignore (E.log "size = %d\n" size); + for i = 0 to size - 1 do + ignore (E.log "Successors(%d): %a\n" i (docList (fun n -> num n)) f.successors.(i)); + done; + end; + + let allScc = strong_components f debug in + let all_sccArray = Array.of_list allScc in + + if (debug) then begin + ignore (E.log "Computed SCCs\n"); + for i = 0 to (Array.length all_sccArray) - 1 do + ignore(E.log "SCC #%d: " i); + let (_,sccNodes) = all_sccArray.(i) in + IntSet.iter (fun i -> ignore(E.log "%d, " i)) sccNodes; + ignore(E.log "\n"); + done; + end; + + + (* Construct sccId: Node -> Scc Id *) + let sccId = Array.make size (-1) in + Array.iteri (fun i (r,sccNodes) -> + IntSet.iter (fun n -> sccId.(n) <- i) sccNodes; + ) all_sccArray; + + if (debug) then begin + ignore (E.log "\nComputed SCC IDs: "); + for i = 0 to size - 1 do + ignore (E.log "SCCID(%d) = %d " i sccId.(i)); + done; + end; + + + (* Construct sccCFG *) + let nrScc = Array.length all_sccArray in + let successors = Array.make nrScc [] in + for x = 0 to nrScc - 1 do + successors.(x) <- + let s = ref(IntSet.empty) in + IntSet.iter (fun y -> + List.iter (fun z -> + let sy = sccId.(y) in + let sz = sccId.(z) in + if (not(sy = sz)) then begin + s := IntSet.add sz !s; + end + ) f.successors.(y) + ) (snd all_sccArray.(x)); + set2list !s + done; + + if (debug) then begin + ignore (E.log "\nComputed SCC CFG, which should be a DAG:"); + ignore (E.log "nrSccs = %d " nrScc); + for i = 0 to nrScc - 1 do + ignore (E.log "successors(%d) = [%a] " i (docList (fun j -> num j)) successors.(i)); + done; + end; + + + (* Order SCCs. The graph is a DAG here *) + let sccorder = preorderDAG nrScc successors in + + if (debug) then begin + ignore (E.log "\nComputed SCC Preorder: "); + ignore (E.log "Nodes in Preorder = [%a]" (docList (fun i -> num i)) sccorder); + end; + + (* Order nodes of each SCC. The graph is a SCC here.*) + let scclist = List.map (fun i -> + let successors = Array.create size [] in + for j = 0 to size - 1 do + successors.(j) <- List.filter (fun x -> IntSet.mem x (snd all_sccArray.(i))) f.successors.(j); + done; + preorder f.size successors (fst all_sccArray.(i)) + ) sccorder in + if (debug) then begin + ignore (E.log "Computed Preorder for Nodes of each SCC\n"); + List.iter (fun scc -> + ignore (E.log "BackEdges = %a \n" + (docList (fun (src,dest) -> dprintf "(%d,%d)" src dest)) + scc.backEdges);) + scclist; + end; + scclist + + + + + + + + + diff --git a/cil/src/ext/ssa.mli b/cil/src/ext/ssa.mli new file mode 100644 index 0000000..be244d8 --- /dev/null +++ b/cil/src/ext/ssa.mli @@ -0,0 +1,45 @@ +type cfgInfo = { + name: string; (* The function name *) + start : int; + size : int; + blocks: cfgBlock array; (** Dominating blocks must come first *) + successors: int list array; (* block indices *) + predecessors: int list array; + mutable nrRegs: int; + mutable regToVarinfo: Cil.varinfo array; (** Map register IDs to varinfo *) + } + +(** A block corresponds to a statement *) +and cfgBlock = { + bstmt: Cil.stmt; + + (* We abstract the statement as a list of def/use instructions *) + instrlist: instruction list; + mutable livevars: (reg * int) list; + (** For each variable ID that is live at the start of the block, the + * block whose definition reaches this point. If that block is the same + * as the current one, then the variable is a phi variable *) + mutable reachable: bool; + } + +and instruction = (reg list * reg list) + (* lhs variables, variables on rhs. *) + + +and reg = int + +type idomInfo = int array (* immediate dominator *) + +and dfInfo = (int list) array (* dominance frontier *) + +and oneSccInfo = { + nodes: int list; + headers: int list; + backEdges: (int*int) list; + } + +and sccInfo = oneSccInfo list + +val add_ssa_info: cfgInfo -> unit +val stronglyConnectedComponents: cfgInfo -> bool -> sccInfo +val prune_cfg: cfgInfo -> cfgInfo diff --git a/cil/src/ext/stackoverflow.ml b/cil/src/ext/stackoverflow.ml new file mode 100644 index 0000000..da2c401 --- /dev/null +++ b/cil/src/ext/stackoverflow.ml @@ -0,0 +1,246 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +module H = Hashtbl +open Cil +open Pretty +module E = Errormsg + +let debug = false + + +(* For each function we have a node *) +type node = { name: string; + mutable scanned: bool; + mutable mustcheck: bool; + mutable succs: node list } +(* We map names to nodes *) +let functionNodes: (string, node) H.t = H.create 113 +let getFunctionNode (n: string) : node = + Util.memoize + functionNodes + n + (fun _ -> { name = n; mustcheck = false; scanned = false; succs = [] }) + +(** Dump the function call graph. Assume that there is a main *) +let dumpGraph = true +let dumpFunctionCallGraph () = + H.iter (fun _ x -> x.scanned <- false) functionNodes; + let rec dumpOneNode (ind: int) (n: node) : unit = + output_string !E.logChannel "\n"; + for i = 0 to ind do + output_string !E.logChannel " " + done; + output_string !E.logChannel (n.name ^ " "); + if n.scanned then (* Already dumped *) + output_string !E.logChannel " " + else begin + n.scanned <- true; + List.iter (dumpOneNode (ind + 1)) n.succs + end + in + try + let main = H.find functionNodes "main" in + dumpOneNode 0 main + with Not_found -> begin + ignore (E.log + "I would like to dump the function graph but there is no main"); + end + +(* We add a dummy function whose name is "@@functionPointer@@" that is called + * at all invocations of function pointers and itself calls all functions + * whose address is taken. *) +let functionPointerName = "@@functionPointer@@" + +let checkSomeFunctions = ref false + +let init () = + H.clear functionNodes; + checkSomeFunctions := false + + +let addCall (caller: string) (callee: string) = + let callerNode = getFunctionNode caller in + let calleeNode = getFunctionNode callee in + if not (List.exists (fun n -> n.name = callee) callerNode.succs) then begin + if debug then + ignore (E.log "found call from %s to %s\n" caller callee); + callerNode.succs <- calleeNode :: callerNode.succs; + end; + () + + +class findCallsVisitor (host: string) : cilVisitor = object + inherit nopCilVisitor + + method vinst i = + match i with + | Call(_,Lval(Var(vi),NoOffset),_,l) -> + addCall host vi.vname; + SkipChildren + + | Call(_,e,_,l) -> (* Calling a function pointer *) + addCall host functionPointerName; + SkipChildren + + | _ -> SkipChildren (* No calls in other instructions *) + + (* There are no calls in expressions and types *) + method vexpr e = SkipChildren + method vtype t = SkipChildren + +end + +(* Now detect the cycles in the call graph. Do a depth first search of the + * graph (stack is the list of nodes already visited in the current path). + * Return true if we have found a cycle. *) +let rec breakCycles (stack: node list) (n: node) : bool = + if n.scanned then (* We have already scanned this node. There are no cycles + * going through this node *) + false + else if n.mustcheck then + (* We are reaching a node that we already know we much check. Return with + * no new cycles. *) + false + else if List.memq n stack then begin + (* We have found a cycle. Mark the node n to be checked and return *) + if debug then + ignore (E.log "Will place an overflow check in %s\n" n.name); + checkSomeFunctions := true; + n.mustcheck <- true; + n.scanned <- true; + true + end else begin + let res = List.exists (fun nd -> breakCycles (n :: stack) nd) n.succs in + n.scanned <- true; + if res && n.mustcheck then + false + else + res + end +let findCheckPlacement () = + H.iter (fun _ nd -> + if nd.name <> functionPointerName + && not nd.scanned && not nd.mustcheck then begin + ignore (breakCycles [] nd) + end) + functionNodes + +let makeFunctionCallGraph (f: Cil.file) : unit = + init (); + (* Scan the file and construct the control-flow graph *) + List.iter + (function + GFun(fdec, _) -> + if fdec.svar.vaddrof then + addCall functionPointerName fdec.svar.vname; + let vis = new findCallsVisitor fdec.svar.vname in + ignore (visitCilBlock vis fdec.sbody) + + | _ -> ()) + f.globals + +let makeAndDumpFunctionCallGraph (f: file) = + makeFunctionCallGraph f; + dumpFunctionCallGraph () + + +let addCheck (f: Cil.file) : unit = + makeFunctionCallGraph f; + findCheckPlacement (); + if !checkSomeFunctions then begin + (* Add a declaration for the stack threshhold variable. The program is + * stopped when the stack top is less than this value. *) + let stackThreshholdVar = makeGlobalVar "___stack_threshhold" !upointType in + stackThreshholdVar.vstorage <- Extern; + (* And the initialization function *) + let computeStackThreshhold = + makeGlobalVar "___compute_stack_threshhold" + (TFun(!upointType, Some [], false, [])) in + computeStackThreshhold.vstorage <- Extern; + (* And the failure function *) + let stackOverflow = + makeGlobalVar "___stack_overflow" + (TFun(voidType, Some [], false, [])) in + stackOverflow.vstorage <- Extern; + f.globals <- + GVar(stackThreshholdVar, {init=None}, locUnknown) :: + GVarDecl(computeStackThreshhold, locUnknown) :: + GVarDecl(stackOverflow, locUnknown) :: f.globals; + (* Now scan and instrument each function definition *) + List.iter + (function + GFun(fdec, l) -> + (* If this is main we must introduce the initialization of the + * bottomOfStack *) + let nd = getFunctionNode fdec.svar.vname in + if fdec.svar.vname = "main" then begin + if nd.mustcheck then + E.s (E.error "The \"main\" function is recursive!!"); + let loc = makeLocalVar fdec "__a_local" intType in + loc.vaddrof <- true; + fdec.sbody <- + mkBlock + [ mkStmtOneInstr + (Call (Some(var stackThreshholdVar), + Lval(var computeStackThreshhold), [], l)); + mkStmt (Block fdec.sbody) ] + end else if nd.mustcheck then begin + let loc = makeLocalVar fdec "__a_local" intType in + loc.vaddrof <- true; + fdec.sbody <- + mkBlock + [ mkStmt + (If(BinOp(Le, + CastE(!upointType, AddrOf (var loc)), + Lval(var stackThreshholdVar), intType), + mkBlock [mkStmtOneInstr + (Call(None, Lval(var stackOverflow), + [], l))], + mkBlock [], + l)); + mkStmt (Block fdec.sbody) ] + end else + () + + | _ -> ()) + f.globals; + () + end + + + + diff --git a/cil/src/ext/stackoverflow.mli b/cil/src/ext/stackoverflow.mli new file mode 100644 index 0000000..6ec0200 --- /dev/null +++ b/cil/src/ext/stackoverflow.mli @@ -0,0 +1,43 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* This module inserts code to check for stack overflow. It saves the address + * of the top of the stack in "main" and then it picks one function *) + +val addCheck: Cil.file -> unit + +val makeAndDumpFunctionCallGraph: Cil.file -> unit diff --git a/cil/src/ext/usedef.ml b/cil/src/ext/usedef.ml new file mode 100755 index 0000000..57f226a --- /dev/null +++ b/cil/src/ext/usedef.ml @@ -0,0 +1,188 @@ +(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) + + +open Cil +open Pretty + +(** compute use/def information *) + +module VS = Set.Make (struct + type t = Cil.varinfo + let compare v1 v2 = Pervasives.compare v1.vid v2.vid + end) + +(** Set this global to how you want to handle function calls *) +let getUseDefFunctionRef: (exp -> VS.t * VS.t) ref = + ref (fun _ -> (VS.empty, VS.empty)) + +(** Say if you want to consider a variable use *) +let considerVariableUse: (varinfo -> bool) ref = + ref (fun _ -> true) + + +(** Say if you want to consider a variable def *) +let considerVariableDef: (varinfo -> bool) ref = + ref (fun _ -> true) + +(** Save if you want to consider a variable addrof as a use *) +let considerVariableAddrOfAsUse: (varinfo -> bool) ref = + ref (fun _ -> true) + +(* When this is true, only definitions of a variable without + an offset are counted as definitions. So: + a = 5; would be a definition, but + a[1] = 5; would not *) +let onlyNoOffsetsAreDefs: bool ref = ref false + +let varUsed: VS.t ref = ref VS.empty +let varDefs: VS.t ref = ref VS.empty + +class useDefVisitorClass : cilVisitor = object (self) + inherit nopCilVisitor + + (** this will be invoked on variable definitions only because we intercept + * all uses of variables in expressions ! *) + method vvrbl (v: varinfo) = + if (!considerVariableDef) v && + not(!onlyNoOffsetsAreDefs) then + varDefs := VS.add v !varDefs; + SkipChildren + + (** If onlyNoOffsetsAreDefs is true, then we need to see the + * varinfo in an lval along with the offset. Otherwise just + * DoChildren *) + method vlval (l: lval) = + if !onlyNoOffsetsAreDefs then + match l with + (Var vi, NoOffset) -> + if (!considerVariableDef) vi then + varDefs := VS.add vi !varDefs; + SkipChildren + | _ -> DoChildren + else DoChildren + + method vexpr = function + Lval (Var v, off) -> + ignore (visitCilOffset (self :> cilVisitor) off); + if (!considerVariableUse) v then + varUsed := VS.add v !varUsed; + SkipChildren (* So that we do not see the v *) + + | AddrOf (Var v, off) + | StartOf (Var v, off) -> + ignore (visitCilOffset (self :> cilVisitor) off); + if (!considerVariableAddrOfAsUse) v then + varUsed := VS.add v !varUsed; + SkipChildren + + | _ -> DoChildren + + (* For function calls, do the transitive variable read/defs *) + method vinst = function + Call (_, f, _, _) -> begin + (* we will call DoChildren to compute the use and def that appear in + * this instruction. We also add in the stuff computed by + * getUseDefFunctionRef *) + let use, def = !getUseDefFunctionRef f in + varUsed := VS.union !varUsed use; + varDefs := VS.union !varDefs def; + DoChildren; + end + | Asm(_,_,slvl,_,_,_) -> List.iter (fun (s,lv) -> + match lv with (Var v, off) -> + if s.[0] = '+' then + varUsed := VS.add v !varUsed; + | _ -> ()) slvl; + DoChildren + | _ -> DoChildren + +end + +let useDefVisitor = new useDefVisitorClass + +(** Compute the use information for an expression (accumulate to an existing + * set) *) +let computeUseExp ?(acc=VS.empty) (e: exp) : VS.t = + varUsed := acc; + ignore (visitCilExpr useDefVisitor e); + !varUsed + + +(** Compute the use/def information for an instruction *) +let computeUseDefInstr ?(acc_used=VS.empty) + ?(acc_defs=VS.empty) + (i: instr) : VS.t * VS.t = + varUsed := acc_used; + varDefs := acc_defs; + ignore (visitCilInstr useDefVisitor i); + !varUsed, !varDefs + + +(** Compute the use/def information for a statement kind. Do not descend into + * the nested blocks. *) +let computeUseDefStmtKind ?(acc_used=VS.empty) + ?(acc_defs=VS.empty) + (sk: stmtkind) : VS.t * VS.t = + varUsed := acc_used; + varDefs := acc_defs; + let ve e = ignore (visitCilExpr useDefVisitor e) in + let _ = + match sk with + Return (None, _) -> () + | Return (Some e, _) -> ve e + | If (e, _, _, _) -> ve e + | Break _ | Goto _ | Continue _ -> () +(* + | Loop (_, _, _, _) -> () +*) + | While _ | DoWhile _ | For _ -> () + | Switch (e, _, _, _) -> ve e + | Instr il -> + List.iter (fun i -> ignore (visitCilInstr useDefVisitor i)) il + | TryExcept _ | TryFinally _ -> () + | Block _ -> () + in + !varUsed, !varDefs + +(* Compute the use/def information for a statement kind. + DO descend into nested blocks *) +let rec computeDeepUseDefStmtKind ?(acc_used=VS.empty) + ?(acc_defs=VS.empty) + (sk: stmtkind) : VS.t * VS.t = + let handle_block b = + List.fold_left (fun (u,d) s -> + let u',d' = computeDeepUseDefStmtKind s.skind in + (VS.union u u', VS.union d d')) (VS.empty, VS.empty) + b.bstmts + in + varUsed := acc_used; + varDefs := acc_defs; + let ve e = ignore (visitCilExpr useDefVisitor e) in + match sk with + Return (None, _) -> !varUsed, !varDefs + | Return (Some e, _) -> + let _ = ve e in + !varUsed, !varDefs + | If (e, tb, fb, _) -> + let _ = ve e in + let u, d = !varUsed, !varDefs in + let u', d' = handle_block tb in + let u'', d'' = handle_block fb in + (VS.union (VS.union u u') u'', VS.union (VS.union d d') d'') + | Break _ | Goto _ | Continue _ -> !varUsed, !varDefs +(* + | Loop (b, _, _, _) -> handle_block b +*) + | While (_, b, _) -> handle_block b + | DoWhile (_, b, _) -> handle_block b + | For (_, _, _, b, _) -> handle_block b + | Switch (e, b, _, _) -> + let _ = ve e in + let u, d = !varUsed, !varDefs in + let u', d' = handle_block b in + (VS.union u u', VS.union d d') + | Instr il -> + List.iter (fun i -> ignore (visitCilInstr useDefVisitor i)) il; + !varUsed, !varDefs + | TryExcept _ | TryFinally _ -> !varUsed, !varDefs + | Block b -> handle_block b diff --git a/cil/src/formatcil.ml b/cil/src/formatcil.ml new file mode 100644 index 0000000..33bc749 --- /dev/null +++ b/cil/src/formatcil.ml @@ -0,0 +1,215 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +open Cil +open Pretty +open Trace (* sm: 'trace' function *) +module E = Errormsg +module H = Hashtbl + +let noMemoize = ref false + +let expMemoTable : + (string, (((string * formatArg) list -> exp) * + (exp -> formatArg list option))) H.t = H.create 23 + +let typeMemoTable : + (string, (((string * formatArg) list -> typ) * + (typ -> formatArg list option))) H.t = H.create 23 + +let lvalMemoTable : + (string, (((string * formatArg) list -> lval) * + (lval -> formatArg list option))) H.t = H.create 23 + +let instrMemoTable : + (string, ((location -> (string * formatArg) list -> instr) * + (instr -> formatArg list option))) H.t = H.create 23 + +let stmtMemoTable : + (string, ((string -> typ -> varinfo) -> + location -> + (string * formatArg) list -> stmt)) H.t = H.create 23 + +let stmtsMemoTable : + (string, ((string -> typ -> varinfo) -> + location -> + (string * formatArg) list -> stmt list)) H.t = H.create 23 + + +let doParse (prog: string) + (theParser: (Lexing.lexbuf -> Formatparse.token) + -> Lexing.lexbuf -> 'a) + (memoTable: (string, 'a) H.t) : 'a = + try + if !noMemoize then raise Not_found else + H.find memoTable prog + with Not_found -> begin + let lexbuf = Formatlex.init prog in + try + Formatparse.initialize Formatlex.initial lexbuf; + let res = theParser Formatlex.initial lexbuf in + H.add memoTable prog res; + Formatlex.finish (); + res + with Parsing.Parse_error -> begin + Formatlex.finish (); + E.s (E.error "Parsing error: %s" prog) + end + | e -> begin + ignore (E.log "Caught %s while parsing\n" (Printexc.to_string e)); + Formatlex.finish (); + raise e + end + end + + +let cExp (prog: string) : (string * formatArg) list -> exp = + let cf = doParse prog Formatparse.expression expMemoTable in + (fst cf) + +let cLval (prog: string) : (string * formatArg) list -> lval = + let cf = doParse prog Formatparse.lval lvalMemoTable in + (fst cf) + +let cType (prog: string) : (string * formatArg) list -> typ = + let cf = doParse prog Formatparse.typename typeMemoTable in + (fst cf) + +let cInstr (prog: string) : location -> (string * formatArg) list -> instr = + let cf = doParse prog Formatparse.instr instrMemoTable in + (fst cf) + +let cStmt (prog: string) : (string -> typ -> varinfo) -> + location -> (string * formatArg) list -> stmt = + let cf = doParse prog Formatparse.stmt stmtMemoTable in + cf + +let cStmts (prog: string) : + (string -> typ -> varinfo) -> + location -> (string * formatArg) list -> stmt list = + let cf = doParse prog Formatparse.stmt_list stmtsMemoTable in + cf + + + +(* Match an expression *) +let dExp (prog: string) : exp -> formatArg list option = + let df = doParse prog Formatparse.expression expMemoTable in + (snd df) + +(* Match an lvalue *) +let dLval (prog: string) : lval -> formatArg list option = + let df = doParse prog Formatparse.lval lvalMemoTable in + (snd df) + + +(* Match a type *) +let dType (prog: string) : typ -> formatArg list option = + let df = doParse prog Formatparse.typename typeMemoTable in + (snd df) + + + +(* Match an instruction *) +let dInstr (prog: string) : instr -> formatArg list option = + let df = doParse prog Formatparse.instr instrMemoTable in + (snd df) + + +let test () = + (* Construct a dummy function *) + let func = emptyFunction "test_formatcil" in + (* Construct a few varinfo *) + let res = makeLocalVar func "res" (TPtr(intType, [])) in + let fptr = makeLocalVar func "fptr" + (TPtr(TFun(intType, None, false, []), [])) in + (* Construct an instruction *) + let makeInstr () = + Call(Some (var res), + Lval (Mem (CastE(TPtr(TFun(TPtr(intType, []), + Some [ ("", intType, []); + ("a2", TPtr(intType, []), []); + ("a3", TPtr(TPtr(intType, []), + []), []) ], + false, []), []), + Lval (var fptr))), + NoOffset), + [ ], locUnknown) + in + let times = 100000 in + (* Make the instruction the regular way *) + Stats.time "make instruction regular" + (fun _ -> for i = 0 to times do ignore (makeInstr ()) done) + (); + (* Now make the instruction interpreted *) + noMemoize := true; + Stats.time "make instruction interpreted" + (fun _ -> for i = 0 to times do + let _ = + cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();" + locUnknown [ ("res", Fv res); + ("fptr", Fv fptr) ] + in + () + done) + (); + (* Now make the instruction interpreted with memoization *) + noMemoize := false; + Stats.time "make instruction interpreted memoized" + (fun _ -> for i = 0 to times do + let _ = + cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();" + locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ] + in + () + done) + (); + (* Now make the instruction interpreted with partial application *) + let partInstr = + cInstr "%v:res = (* ((int * (*)(int, int * a2, int * * a3))%v:fptr))();" in + Stats.time "make instruction interpreted partial" + (fun _ -> for i = 0 to times do + let _ = + partInstr + locUnknown [ ("res", Fv res); ("fptr", Fv fptr) ] + in + () + done) + (); + + () + + diff --git a/cil/src/formatcil.mli b/cil/src/formatcil.mli new file mode 100644 index 0000000..d353c5e --- /dev/null +++ b/cil/src/formatcil.mli @@ -0,0 +1,103 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + +(** {b An Interpreter for constructing CIL constructs} *) + + +(** Constructs an expression based on the program and the list of arguments. + * Each argument consists of a name followed by the actual data. This + * argument will be placed instead of occurrences of "%v:name" in the pattern + * (where the "v" is dependent on the type of the data). The parsing of the + * string is memoized. * Only the first expression is parsed. *) +val cExp: string -> (string * Cil.formatArg) list -> Cil.exp + +(** Constructs an lval based on the program and the list of arguments. + * Only the first lvalue is parsed. + * The parsing of the string is memoized. *) +val cLval: string -> (string * Cil.formatArg) list -> Cil.lval + +(** Constructs a type based on the program and the list of arguments. + * Only the first type is parsed. + * The parsing of the string is memoized. *) +val cType: string -> (string * Cil.formatArg) list -> Cil.typ + + +(** Constructs an instruction based on the program and the list of arguments. + * Only the first instruction is parsed. + * The parsing of the string is memoized. *) +val cInstr: string -> Cil.location -> + (string * Cil.formatArg) list -> Cil.instr + +(* Constructs a statement based on the program and the list of arguments. We + * also pass a function that can be used to make new varinfo's for the + * declared variables, and a location to be used for the statements. Only the + * first statement is parsed. The parsing of the string is memoized. *) +val cStmt: string -> + (string -> Cil.typ -> Cil.varinfo) -> + Cil.location -> (string * Cil.formatArg) list -> Cil.stmt + +(** Constructs a list of statements *) +val cStmts: string -> + (string -> Cil.typ -> Cil.varinfo) -> + Cil.location -> (string * Cil.formatArg) list -> + Cil.stmt list + +(** Deconstructs an expression based on the program. Produces an optional + * list of format arguments. The parsing of the string is memoized. *) +val dExp: string -> Cil.exp -> Cil.formatArg list option + +(** Deconstructs an lval based on the program. Produces an optional + * list of format arguments. The parsing of the string is memoized. *) +val dLval: string -> Cil.lval -> Cil.formatArg list option + + +(** Deconstructs a type based on the program. Produces an optional list of + * format arguments. The parsing of the string is memoized. *) +val dType: string -> Cil.typ -> Cil.formatArg list option + + +(** Deconstructs an instruction based on the program. Produces an optional + * list of format arguments. The parsing of the string is memoized. *) +val dInstr: string -> Cil.instr -> Cil.formatArg list option + + +(** If set then will not memoize the parsed patterns *) +val noMemoize: bool ref + +(** Just a testing function *) +val test: unit -> unit diff --git a/cil/src/formatlex.mll b/cil/src/formatlex.mll new file mode 100644 index 0000000..584a060 --- /dev/null +++ b/cil/src/formatlex.mll @@ -0,0 +1,308 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +(* A simple lexical analyzer for constructing CIL based on format strings *) +{ +open Formatparse +exception Eof +exception InternalError of string +module H = Hashtbl +module E = Errormsg +(* +** Keyword hashtable +*) +let keywords = H.create 211 + +(* +** Useful primitives +*) +let scan_ident id = + try H.find keywords id + with Not_found -> IDENT id (* default to variable name *) + +(* +** Buffer processor +*) + + +let init ~(prog: string) : Lexing.lexbuf = + H.clear keywords; + Lexerhack.currentPattern := prog; + List.iter + (fun (key, token) -> H.add keywords key token) + [ ("const", CONST); ("__const", CONST); ("__const__", CONST); + ("static", STATIC); + ("extern", EXTERN); + ("long", LONG); + ("short", SHORT); + ("signed", SIGNED); + ("unsigned", UNSIGNED); + ("volatile", VOLATILE); + ("char", CHAR); + ("int", INT); + ("float", FLOAT); + ("double", DOUBLE); + ("void", VOID); + ("enum", ENUM); + ("struct", STRUCT); + ("typedef", TYPEDEF); + ("union", UNION); + ("break", BREAK); + ("continue", CONTINUE); + ("goto", GOTO); + ("return", RETURN); + ("switch", SWITCH); + ("case", CASE); + ("default", DEFAULT); + ("while", WHILE); + ("do", DO); + ("for", FOR); + ("if", IF); + ("else", ELSE); + ("__attribute__", ATTRIBUTE); ("__attribute", ATTRIBUTE); + ("__int64", INT64); + ("__builtin_va_arg", BUILTIN_VA_ARG); + ]; + E.startParsingFromString prog + +let finish () = + E.finishParsing () + +(*** Error handling ***) +let error msg = + E.parse_error msg + + +(*** escape character management ***) +let scan_escape str = + match str with + "n" -> "\n" + | "r" -> "\r" + | "t" -> "\t" + | "b" -> "\b" + | "f" -> "\012" (* ASCII code 12 *) + | "v" -> "\011" (* ASCII code 11 *) + | "a" -> "\007" (* ASCII code 7 *) + | "e" -> "\027" (* ASCII code 27. This is a GCC extension *) + | _ -> str + +let get_value chr = + match chr with + '0'..'9' -> (Char.code chr) - (Char.code '0') + | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10 + | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10 + | _ -> 0 +let scan_hex_escape str = + String.make 1 (Char.chr ( + (get_value (String.get str 0)) * 16 + + (get_value (String.get str 1)) + )) +let scan_oct_escape str = + (* weimer: wide-character constants like L'\400' may be bigger than + * 256 (in fact, may be up to 511), so Char.chr cannot be used directly *) + let the_value = (get_value (String.get str 0)) * 64 + + (get_value (String.get str 1)) * 8 + + (get_value (String.get str 2)) in + if the_value < 256 then String.make 1 (Char.chr the_value ) + else (String.make 1 (Char.chr (the_value / 256))) ^ + (String.make 1 (Char.chr (the_value mod 256))) + +(* ISO standard locale-specific function to convert a wide character + * into a sequence of normal characters. Here we work on strings. + * We convert L"Hi" to "H\000i\000" *) +let wbtowc wstr = + let len = String.length wstr in + let dest = String.make (len * 2) '\000' in + for i = 0 to len-1 do + dest.[i*2] <- wstr.[i] ; + done ; + dest + +(* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' } *) +let wstr_to_warray wstr = + let len = String.length wstr in + let res = ref "{ " in + for i = 0 to len-1 do + res := !res ^ (Printf.sprintf "L'%c', " wstr.[i]) + done ; + res := !res ^ "}" ; + !res + +let getArgName (l: Lexing.lexbuf) (prefixlen: int) = + let lexeme = Lexing.lexeme l in + let ll = String.length lexeme in + if ll > prefixlen then + String.sub lexeme (prefixlen + 1) (ll - prefixlen - 1) + else + "" +} + +let decdigit = ['0'-'9'] +let octdigit = ['0'-'7'] +let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F'] +let letter = ['a'- 'z' 'A'-'Z'] + +let floatsuffix = ['f' 'F' 'l' 'L'] + +let usuffix = ['u' 'U'] +let lsuffix = "l"|"L"|"ll"|"LL" +let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix + +let intnum = decdigit+ intsuffix? +let octnum = '0' octdigit+ intsuffix? +let hexnum = '0' ['x' 'X'] hexdigit+ intsuffix? + +let exponent = ['e' 'E']['+' '-']? decdigit+ +let fraction = '.' decdigit+ +let floatraw = (intnum? fraction) + |(intnum exponent) + |(intnum? fraction exponent) + |(intnum '.') + |(intnum '.' exponent) +let floatnum = floatraw floatsuffix? + +let ident = (letter|'_')(letter|decdigit|'_')* +let attribident = (letter|'_')(letter|decdigit|'_'|':') +let blank = [' ' '\t' '\012' '\r'] +let escape = '\\' _ +let hex_escape = '\\' ['x' 'X'] hexdigit hexdigit +let oct_escape = '\\' octdigit octdigit octdigit + + +(* The arguments are of the form %l:foo *) +let argname = ':' ident + +rule initial = + parse blank { initial lexbuf} +| "/*" { let _ = comment lexbuf in + initial lexbuf} +| "//" { endline lexbuf } +| "\n" { E.newline (); initial lexbuf} +| floatnum {CST_FLOAT (Lexing.lexeme lexbuf)} +| hexnum {CST_INT (Lexing.lexeme lexbuf)} +| octnum {CST_INT (Lexing.lexeme lexbuf)} +| intnum {CST_INT (Lexing.lexeme lexbuf)} + +| "<<=" {INF_INF_EQ} +| ">>=" {SUP_SUP_EQ} +| "*=" {STAR_EQ} +| "/=" {SLASH_EQ} +| "&=" {AND_EQ} +| "|=" {PIPE_EQ} +| "^=" {CIRC_EQ} +| "%=" {PERCENT_EQ} + + +| "..." {ELLIPSIS} +| "-=" {MINUS_EQ} +| "+=" {PLUS_EQ} +| "*=" {STAR_EQ} +| "<<" {INF_INF} +| ">>" {SUP_SUP} +| "==" {EQ_EQ} +| "!=" {EXCLAM_EQ} +| "<=" {INF_EQ} +| ">=" {SUP_EQ} +| "=" {EQ} +| "<" {INF} +| ">" {SUP} +| "++" {PLUS_PLUS} +| "--" {MINUS_MINUS} +| "->" {ARROW} +| '+' {PLUS} +| '-' {MINUS} +| '*' {STAR} +| '/' {SLASH} +| '!' {EXCLAM} +| '&' {AND} +| '|' {PIPE} +| '^' {CIRC} +| '~' {TILDE} +| '[' {LBRACKET} +| ']' {RBRACKET} +| '{' {LBRACE} +| '}' {RBRACE} +| '(' {LPAREN} +| ')' {RPAREN} +| ';' {SEMICOLON} +| ',' {COMMA} +| '.' {DOT} +| ':' {COLON} +| '?' {QUEST} +| "sizeof" {SIZEOF} + +| "%eo" argname {ARG_eo (getArgName lexbuf 3) } +| "%e" argname {ARG_e (getArgName lexbuf 2) } +| "%E" argname {ARG_E (getArgName lexbuf 2) } +| "%u" argname {ARG_u (getArgName lexbuf 2) } +| "%b" argname {ARG_b (getArgName lexbuf 2) } +| "%t" argname {ARG_t (getArgName lexbuf 2) } +| "%d" argname {ARG_d (getArgName lexbuf 2) } +| "%lo" argname {ARG_lo (getArgName lexbuf 3) } +| "%l" argname {ARG_l (getArgName lexbuf 2) } +| "%i" argname {ARG_i (getArgName lexbuf 2) } +| "%I" argname {ARG_I (getArgName lexbuf 2) } +| "%o" argname {ARG_o (getArgName lexbuf 2) } +| "%va" argname {ARG_va (getArgName lexbuf 3) } +| "%v" argname {ARG_v (getArgName lexbuf 2) } +| "%k" argname {ARG_k (getArgName lexbuf 2) } +| "%f" argname {ARG_f (getArgName lexbuf 2) } +| "%F" argname {ARG_F (getArgName lexbuf 2) } +| "%p" argname {ARG_p (getArgName lexbuf 2) } +| "%P" argname {ARG_P (getArgName lexbuf 2) } +| "%s" argname {ARG_s (getArgName lexbuf 2) } +| "%S" argname {ARG_S (getArgName lexbuf 2) } +| "%g" argname {ARG_g (getArgName lexbuf 2) } +| "%A" argname {ARG_A (getArgName lexbuf 2) } +| "%c" argname {ARG_c (getArgName lexbuf 2) } + +| '%' {PERCENT} +| ident {scan_ident (Lexing.lexeme lexbuf)} +| eof {EOF} +| _ {E.parse_error + "Formatlex: Invalid symbol" + } + +and comment = + parse + "*/" { () } +| '\n' { E.newline (); comment lexbuf } +| _ { comment lexbuf } + + +and endline = parse + '\n' { E.newline (); initial lexbuf} +| _ { endline lexbuf} diff --git a/cil/src/formatparse.mly b/cil/src/formatparse.mly new file mode 100644 index 0000000..75bdbb3 --- /dev/null +++ b/cil/src/formatparse.mly @@ -0,0 +1,1455 @@ +/* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. */ + +/*(* Parser for constructing CIL from format strings *) +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +*/ +%{ +open Cil +open Pretty +module E = Errormsg + +let parse_error msg : 'a = (* sm: c++-mode highlight hack: -> ' <- *) + E.hadErrors := true; + E.parse_error + msg + + +let getArg (argname: string) (args: (string * formatArg) list) = + try + snd (List.find (fun (n, a) -> n = argname) args) + with _ -> + E.s (error "Pattern string %s does not have argument with name %s\n" + !Lexerhack.currentPattern argname) + +let wrongArgType (which: string) (expected: string) (found: formatArg) = + E.s (bug "Expecting %s argument (%s) and found %a\n" + expected which d_formatarg found) + +let doUnop (uo: unop) subexp = + ((fun args -> + let e = (fst subexp) args in + UnOp(uo, e, typeOf e)), + + (fun e -> match e with + UnOp(uo', e', _) when uo = uo' -> (snd subexp) e' + | _ -> None)) + +let buildPlus e1 e2 : exp = + let t1 = typeOf e1 in + if isPointerType t1 then + BinOp(PlusPI, e1, e2, t1) + else + BinOp(PlusA, e1, e2, t1) + +let buildMinus e1 e2 : exp = + let t1 = typeOf e1 in + let t2 = typeOf e2 in + if isPointerType t1 then + if isPointerType t2 then + BinOp(MinusPP, e1, e2, intType) + else + BinOp(MinusPI, e1, e2, t1) + else + BinOp(MinusA, e1, e2, t1) + +let doBinop bop e1t e2t = + ((fun args -> + let e1 = (fst e1t) args in + let e2 = (fst e2t) args in + let t1 = typeOf e1 in + BinOp(bop, e1, e2, t1)), + + (fun e -> match e with + BinOp(bop', e1, e2, _) when bop' = bop -> begin + match (snd e1t) e1, (snd e2t) e2 with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None + end + | _ -> None)) + +(* Check the equivalence of two format lists *) +let rec checkSameFormat (fl1: formatArg list) (fl2: formatArg list) = + match fl1, fl2 with + [], [] -> true + | h1::t1, h2::t2 -> begin + let rec checkOffsetEq o1 o2 = + match o1, o2 with + NoOffset, NoOffset -> true + | Field(f1, o1'), Field(f2, o2') -> + f1.fname = f2.fname && checkOffsetEq o1' o2' + | Index(e1, o1'), Index(e2, o2') -> + checkOffsetEq o1' o2' && checkExpEq e1 e2 + | _, _ -> false + + and checkExpEq e1 e2 = + match e1, e2 with + Const(CInt64(n1, _, _)), Const(CInt64(n2, _, _)) -> n1 = n2 + | Lval l1, Lval l2 -> checkLvalEq l1 l2 + | UnOp(uo1, e1, _), UnOp(uo2, e2, _) -> + uo1 = uo2 && checkExpEq e1 e2 + | BinOp(bo1, e11, e12, _), BinOp(bo2, e21, e22, _) -> + bo1 = bo2 && checkExpEq e11 e21 && checkExpEq e21 e22 + | AddrOf l1, AddrOf l2 -> checkLvalEq l1 l2 + | StartOf l1, StartOf l2 -> checkLvalEq l1 l2 + | SizeOf t1, SizeOf t2 -> typeSig t1 = typeSig t2 + | _, _ -> + ignore (E.warn "checkSameFormat for Fe"); false + + and checkLvalEq l1 l2 = + match l1, l2 with + (Var v1, o1), (Var v2, o2) -> v1 == v2 && checkOffsetEq o1 o2 + | (Mem e1, o1), (Mem e2, o2) -> + checkOffsetEq o1 o2 && checkExpEq e1 e2 + | _, _ -> false + in + let hdeq = + match h1, h2 with + Fv v1, Fv v2 -> v1 == v2 + | Fd n1, Fd n2 -> n1 = n2 + | Fe e1, Fe e2 -> checkExpEq e1 e2 + | Fi i1, Fi i2 -> ignore (E.warn "checkSameFormat for Fi"); false + | Ft t1, Ft t2 -> typeSig t1 = typeSig t2 + | Fl l1, Fl l2 -> checkLvalEq l1 l2 + | Fo o1, Fo o2 -> checkOffsetEq o1 o2 + | Fc c1, Fc c2 -> c1 == c2 + | _, _ -> false + in + hdeq || checkSameFormat t1 t2 + end + | _, _ -> false + +let matchBinopEq (bopeq: binop -> bool) lvt et = + (fun i -> match i with + Set (lv, BinOp(bop', Lval (lv'), e', _), l) when bopeq bop' -> begin + match lvt lv, lvt lv', et e' with + Some m1, Some m1', Some m2 -> + (* Must check that m1 and m2 are the same *) + if checkSameFormat m1 m1' then + Some (m1 @ m2) + else + None + | _, _, _ -> None + end + | _ -> None) + +let doBinopEq bop lvt et = + ((fun loc args -> + let l = (fst lvt) args in + Set(l, BinOp(bop, (Lval l), (fst et) args, typeOfLval l), loc)), + + matchBinopEq (fun bop' -> bop = bop') (snd lvt) (snd et)) + + +let getField (bt: typ) (fname: string) : fieldinfo = + match unrollType bt with + TComp(ci, _) -> begin + try + List.find (fun f -> fname = f.fname) ci.cfields + with Not_found -> + E.s (bug "Cannot find field %s in %s\n" fname (compFullName ci)) + end + | t -> E.s (bug "Trying to access field %s in non-struct\n" fname) + + +let matchIntType (ik: ikind) (t:typ) : formatArg list option = + match unrollType t with + TInt(ik', _) when ik = ik' -> Some [] + | _ -> None + +let matchFloatType (fk: fkind) (t:typ) : formatArg list option = + match unrollType t with + TFloat(fk', _) when fk = fk' -> Some [] + | _ -> None + +let doAttr (id: string) + (aargs: (((string * formatArg) list -> attrparam list) * + (attrparam list -> formatArg list option)) option) + = + let t = match aargs with + Some t -> t + | None -> (fun _ -> []), + (function [] -> Some [] | _ -> None) + in + ((fun args -> Attr (id, (fst t) args)), + + (fun attrs -> + (* Find the attributes with the same ID *) + List.fold_left + (fun acc a -> + match acc, a with + Some _, _ -> acc (* We found one already *) + | None, Attr(id', args) when id = id' -> + (* Now match the arguments *) + (snd t) args + | None, _ -> acc) + None + attrs)) + + +type falist = formatArg list + +type maybeInit = + NoInit + | InitExp of exp + | InitCall of lval * exp list + +%} + +%token IDENT +%token CST_CHAR +%token CST_INT +%token CST_FLOAT +%token CST_STRING +%token CST_WSTRING +%token NAMED_TYPE + +%token EOF +%token CHAR INT DOUBLE FLOAT VOID INT64 INT32 +%token ENUM STRUCT TYPEDEF UNION +%token SIGNED UNSIGNED LONG SHORT +%token VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER + +%token ARG_e ARG_eo ARG_E ARG_u ARG_b ARG_t ARG_d ARG_lo ARG_l ARG_i +%token ARG_o ARG_va ARG_f ARG_F ARG_A ARG_v ARG_k ARG_c ARG_d +%token ARG_s ARG_p ARG_P ARG_I ARG_S ARG_g + +%token SIZEOF ALIGNOF + +%token EQ +%token ARROW DOT + +%token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ +%token MINUS_EQ PLUS_EQ STAR_EQ +%token PLUS MINUS STAR SLASH PERCENT +%token TILDE AND PIPE CIRC +%token EXCLAM AND_AND PIPE_PIPE +%token INF_INF SUP_SUP +%token PLUS_PLUS MINUS_MINUS + +%token RPAREN LPAREN RBRACE LBRACE LBRACKET RBRACKET +%token COLON SEMICOLON COMMA ELLIPSIS QUEST + +%token BREAK CONTINUE GOTO RETURN +%token SWITCH CASE DEFAULT +%token WHILE DO FOR +%token IF THEN ELSE + +%token PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ +%token AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ + +%token ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__ LABEL__ +%token BUILTIN_VA_ARG BUILTIN_VA_LIST +%token BLOCKATTRIBUTE +%token DECLSPEC +%token MSASM MSATTR +%token PRAGMA + + +/* operator precedence */ +%nonassoc IF +%nonassoc ELSE + + +%left COMMA + + /*(* Set the following precedences higer than COMMA *)*/ +%nonassoc ARG_e ARG_d ARG_lo ARG_l ARG_i ARG_v ARG_I ARG_g +%right EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ + AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ +%right COLON +%left PIPE_PIPE +%left AND_AND +%left ARG_b +%left PIPE +%left CIRC +%left AND +%left EQ_EQ EXCLAM_EQ +%left INF SUP INF_EQ SUP_EQ +%left INF_INF SUP_SUP +%left PLUS MINUS +%left STAR SLASH PERCENT CONST RESTRICT VOLATILE +%right ARG_u EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF +%left LBRACKET +%left DOT ARROW LPAREN LBRACE +%nonassoc IDENT QUEST CST_INT + +%start initialize expression typename offset lval instr stmt stmt_list + + +%type initialize +%type <((string -> Cil.typ -> Cil.varinfo) -> Cil.location -> (string * Cil.formatArg) list -> Cil.stmt)> stmt +%type <((string -> Cil.typ -> Cil.varinfo) -> Cil.location -> (string * Cil.formatArg) list -> Cil.stmt list)> stmt_list + +%type <((string * Cil.formatArg) list -> Cil.exp) * (Cil.exp -> Cil.formatArg list option)> expression + +%type <((string * Cil.formatArg) list -> Cil.exp) * (Cil.exp -> Cil.formatArg list option)> constant + +%type <((string * Cil.formatArg) list -> Cil.lval) * (Cil.lval -> Cil.formatArg list option)> lval + +%type <((string * Cil.formatArg) list -> Cil.typ) * (Cil.typ -> Cil.formatArg list option)> typename + +%type <(Cil.attributes -> (string * Cil.formatArg) list -> Cil.typ) * (Cil.typ -> Cil.formatArg list option)> type_spec + +%type <((string * Cil.formatArg) list -> (string * Cil.typ * Cil.attributes) list option * bool) * ((string * Cil.typ * Cil.attributes) list option * bool -> Cil.formatArg list option)> parameters + + +%type <(Cil.location -> (string * Cil.formatArg) list -> Cil.instr) * (Cil.instr -> Cil.formatArg list option)> instr + +%type <(Cil.typ -> (string * Cil.formatArg) list -> Cil.offset) * (Cil.offset -> Cil.formatArg list option)> offset + + +%% + + +initialize: + /* empty */ { } +; + +/* (*** Expressions ***) */ + + +expression: +| ARG_e { (* Count arguments eagerly *) + let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + Fe e -> e + | a -> wrongArgType currentArg + "expression" a), + + (fun e -> Some [ Fe e ])) + } + +| constant { $1 } + +| lval %prec IDENT + { ((fun args -> Lval ((fst $1) args)), + + (fun e -> match e with + Lval l -> (snd $1) l + | _ -> None)) + } + +| SIZEOF expression + { ((fun args -> SizeOfE ((fst $2) args)), + + fun e -> match e with + SizeOfE e' -> (snd $2) e' + | _ -> None) + } + +| SIZEOF LPAREN typename RPAREN + { ((fun args -> SizeOf ((fst $3) args)), + + (fun e -> match e with + SizeOf t -> (snd $3) t + | _ -> None)) + } + +| ALIGNOF expression + { ((fun args -> AlignOfE ((fst $2) args)), + + (fun e -> match e with + AlignOfE e' -> (snd $2) e' | _ -> None)) + } + +| ALIGNOF LPAREN typename RPAREN + { ((fun args -> AlignOf ((fst $3) args)), + + (fun e -> match e with + AlignOf t' -> (snd $3) t' | _ -> None)) + } + +| PLUS expression + { $2 } +| MINUS expression + { doUnop Neg $2 } + +| EXCLAM expression + { doUnop LNot $2 } + +| TILDE expression + { doUnop BNot $2 } + +| argu expression %prec ARG_u + { ((fun args -> + let e = (fst $2) args in + UnOp((fst $1) args, e, typeOf e)), + + (fun e -> match e with + UnOp(uo, e', _) -> begin + match (snd $1) uo, (snd $2) e' with + Some m1, Some m2 -> Some (m1 @ m2) + | _ -> None + end + | _ -> None)) + } + + +| AND expression %prec ADDROF + { ((fun args -> + match (fst $2) args with + Lval l -> mkAddrOf l + | _ -> E.s (bug "AddrOf applied to a non lval")), + (fun e -> match e with + AddrOf l -> (snd $2) (Lval l) + | e -> (snd $2) (Lval (mkMem e NoOffset)))) + } + +| LPAREN expression RPAREN + { $2 } + +| expression PLUS expression + { ((fun args -> buildPlus ((fst $1) args) + ((fst $3) args)), + (fun e -> match e with + BinOp((PlusPI|PlusA), e1, e2, _) -> begin + match (snd $1) e1, (snd $3) e2 with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None + end + | _ -> None)) + } + +| expression MINUS expression + { ((fun args -> buildMinus ((fst $1) args) + ((fst $3) args)), + + (fun e -> match e with + BinOp((MinusPP|MinusPI|MinusA), e1, e2, _) -> + begin + match (snd $1) e1, (snd $3) e2 with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None + end + | _ -> None)) + } +| expression argb expression %prec ARG_b + { ((fun args -> + let e1 = (fst $1) args in + let bop = (fst $2) args in + let e2 = (fst $3) args in + let t1 = typeOf e1 in + BinOp(bop, e1, e2, t1)), + + (fun e -> match e with + BinOp(bop, e1, e2, _) -> begin + match (snd $1) e1,(snd $2) bop,(snd $3) e2 with + Some m1, Some m2, Some m3 -> + Some (m1 @ m2 @ m3) + | _, _, _ -> None + end + | _ -> None)) + } + +| expression STAR expression + { doBinop Mult $1 $3 } +| expression SLASH expression + { doBinop Div $1 $3 } +| expression PERCENT expression + { doBinop Mod $1 $3 } +| expression INF_INF expression + { doBinop Shiftlt $1 $3 } +| expression SUP_SUP expression + { doBinop Shiftrt $1 $3 } +| expression AND expression + { doBinop BAnd $1 $3 } +| expression PIPE expression + { doBinop BOr $1 $3 } +| expression CIRC expression + { doBinop BXor $1 $3 } +| expression EQ_EQ expression + { doBinop Eq $1 $3 } +| expression EXCLAM_EQ expression + { doBinop Ne $1 $3 } +| expression INF expression + { doBinop Lt $1 $3 } +| expression SUP expression + { doBinop Gt $1 $3 } +| expression INF_EQ expression + { doBinop Le $1 $3 } +| expression SUP_EQ expression + { doBinop Ge $1 $3 } + +| LPAREN typename RPAREN expression + { ((fun args -> + let t = (fst $2) args in + let e = (fst $4) args in + mkCast e t), + + (fun e -> + let t', e' = + match e with + CastE (t', e') -> t', e' + | _ -> typeOf e, e + in + match (snd $2) t', (snd $4 e') with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None)) + } +; + +/*(* Separate the ARG_ to ensure that the counting of arguments is right *)*/ +argu : +| ARG_u { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + Fu uo -> uo + | a -> wrongArgType currentArg "unnop" a), + + fun uo -> Some [ Fu uo ]) + } +; + +argb : +| ARG_b { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + Fb bo -> bo + | a -> wrongArgType currentArg "binop" a), + + fun bo -> Some [ Fb bo ]) + } +; + +constant: +| ARG_d { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + Fd n -> integer n + | a -> wrongArgType currentArg "integer" a), + + fun e -> match e with + Const(CInt64(n, _, _)) -> + Some [ Fd (Int64.to_int n) ] + | _ -> None) + } + +| ARG_g { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + Fg s -> Const(CStr s) + | a -> wrongArgType currentArg "string" a), + + fun e -> match e with + Const(CStr s) -> + Some [ Fg s ] + | _ -> None) + } +| CST_INT { let n = parseInt $1 in + ((fun args -> n), + + (fun e -> match e, n with + Const(CInt64(e', _, _)), + Const(CInt64(n', _, _)) when e' = n' -> Some [] + | _ -> None)) + } +; + + +/*(***************** LVALUES *******************)*/ +lval: +| ARG_l { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + Fl l -> l + | Fv v -> Var v, NoOffset + | a -> wrongArgType currentArg "lval" a), + + fun l -> Some [ Fl l ]) + } + +| argv offset %prec ARG_v + { ((fun args -> + let v = (fst $1) args in + (Var v, (fst $2) v.vtype args)), + + (fun l -> match l with + Var vi, off -> begin + match (snd $1) vi, (snd $2) off with + Some m1, Some m2 -> Some (m1 @ m2) + | _ -> None + end + | _ -> None)) + } + +| STAR expression { ((fun args -> mkMem ((fst $2) args) NoOffset), + + (fun l -> match l with + Mem e, NoOffset -> (snd $2) e + | _, _ -> None)) + } + +| expression ARROW IDENT offset + { ((fun args -> + let e = (fst $1) args in + let baset = + match unrollTypeDeep (typeOf e) with + TPtr (t, _) -> t + | _ -> E.s (bug "Expecting a pointer for field %s\n" $3) + in + let fi = getField baset $3 in + mkMem e (Field(fi, (fst $4) fi.ftype args))), + + (fun l -> match l with + Mem e, Field(fi, off) when fi.fname = $3 -> begin + match (snd $1) e, (snd $4) off with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None + end + | _, _ -> None)) + } + +| LPAREN STAR expression RPAREN offset + { ((fun args -> + let e = (fst $3) args in + let baset = + match unrollTypeDeep (typeOf e) with + TPtr (t, _) -> t + | _ -> E.s (bug "Expecting a pointer\n") + in + mkMem e ((fst $5) baset args)), + + (fun l -> match l with + Mem e, off -> begin + match (snd $3) e, (snd $5 off) with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None + end + | _, _ -> None)) + } + ; + +argv : +| ARG_v { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + Fv v -> v + | a -> wrongArgType currentArg "varinfo" a), + + fun v -> Some [ Fv v ]) + } +| IDENT { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + Fv v -> v + | a -> wrongArgType currentArg "varinfo" a), + (fun v -> + E.s (bug "identifiers (%s) are not supported for deconstruction" currentArg))) + } +; + + +/*(********** OFFSETS *************)*/ +offset: +| ARG_o { let currentArg = $1 in + ((fun t args -> + match getArg currentArg args with + Fo o -> o + | a -> wrongArgType currentArg "offset" a), + + (fun off -> Some [ Fo off ])) + } + +| /* empty */ { ((fun t args -> NoOffset), + + (fun off -> match off with + NoOffset -> Some [] + | _ -> None)) + } + +| DOT IDENT offset { ((fun t args -> + let fi = getField t $2 in + Field (fi, (fst $3) fi.ftype args)), + + (fun off -> match off with + Field (fi, off') when fi.fname = $2 -> + (snd $3) off' + | _ -> None)) + } + +| LBRACKET expression RBRACKET offset + { ((fun t args -> + let bt = + match unrollType t with + TArray(bt, _, _) -> bt + | _ -> E.s (error "Formatcil: expecting an array for index") + in + let e = (fst $2) args in + Index(e, (fst $4) bt args)), + + (fun off -> match off with + Index (e, off') -> begin + match (snd $2) e, (snd $4) off with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None + end + | _ -> None)) + } +; + + +/*(************ TYPES **************)*/ +typename: one_formal { ((fun args -> + let (_, ft, _) = (fst $1) args in + ft), + + (fun t -> (snd $1) ("", t, []))) + } +; + +one_formal: +/*(* Do not allow attributes for the name *)*/ +| type_spec attributes decl + { ((fun args -> + let tal = (fst $2) args in + let ts = (fst $1) tal args in + let (fn, ft, _) = (fst $3) ts args in + (fn, ft, [])), + + (fun (fn, ft, fa) -> + match (snd $3) (fn, ft) with + Some (restt, m3) -> begin + match (snd $1) restt, + (snd $2) (typeAttrs restt)with + Some m1, Some m2 -> + Some (m1 @ m2 @ m3) + | _, _ -> None + end + | _ -> None)) + } + +| ARG_f + { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + Ff (fn, ft, fa) -> (fn, ft, fa) + | a -> wrongArgType currentArg "formal" a), + + (fun (fn, ft, fa) -> Some [ Ff (fn, ft, fa) ])) + } +; + +type_spec: +| ARG_t { let currentArg = $1 in + ((fun al args -> + match getArg currentArg args with + Ft t -> typeAddAttributes al t + | a -> wrongArgType currentArg "type" a), + + (fun t -> Some [ Ft t ])) + } + +| VOID { ((fun al args -> TVoid al), + + (fun t -> match unrollType t with + TVoid _ -> Some [] + | _ -> None)) } + +| ARG_k { let currentArg = $1 in + ((fun al args -> + match getArg currentArg args with + Fk ik -> TInt(ik, al) + | a -> wrongArgType currentArg "ikind" a), + + (fun t -> match unrollType t with + TInt(ik, _) -> Some [ Fk ik ] + | _ -> None)) + } + +| CHAR { ((fun al args -> TInt(IChar, al)), + (matchIntType IChar)) } +| UNSIGNED CHAR { ((fun al args -> TInt(IUChar, al)), + matchIntType IUChar) } + +| SHORT { ((fun al args -> TInt(IShort, al)), + matchIntType IShort) } +| UNSIGNED SHORT { ((fun al args -> TInt(IUShort, al)), + matchIntType IUShort) } + +| INT { ((fun al args -> TInt(IInt, al)), + matchIntType IInt) } +| UNSIGNED INT { ((fun al args -> TInt(IUInt, al)), matchIntType IUInt) } + +| LONG { ((fun al args -> TInt(ILong, al)), + matchIntType ILong) } +| UNSIGNED LONG { ((fun al args -> TInt(IULong, al)), + matchIntType IULong) } + +| LONG LONG { ((fun al args -> TInt(ILongLong, al)), + + matchIntType ILongLong) + } +| UNSIGNED LONG LONG { ((fun al args -> TInt(IULongLong, al)), + + matchIntType IULongLong) + } + +| FLOAT { ((fun al args -> TFloat(FFloat, al)), + matchFloatType FFloat) + } +| DOUBLE { ((fun al args -> TFloat(FDouble, al)), + matchFloatType FDouble) } + +| STRUCT ARG_c { let currentArg = $2 in + ((fun al args -> + match getArg currentArg args with + Fc ci -> TComp(ci, al) + | a -> wrongArgType currentArg "compinfo" a), + + (fun t -> match unrollType t with + TComp(ci, _) -> Some [ Fc ci ] + | _ -> None)) + } +| UNION ARG_c { let currentArg = $2 in + ((fun al args -> + match getArg currentArg args with + Fc ci -> TComp(ci, al) + | a -> wrongArgType currentArg "compinfo" a), + + (fun t -> match unrollType t with + TComp(ci, _) -> Some [ Fc ci ] + | _ -> None)) + + } + +| TYPEOF LPAREN expression RPAREN + { ((fun al args -> typeAddAttributes al + (typeOf ((fst $3) args))), + + (fun t -> E.s (bug "Cannot match typeof(e)\n"))) + } +; + +decl: +| STAR attributes decl + { ((fun ts args -> + let al = (fst $2) args in + (fst $3) (TPtr(ts, al)) args), + + (fun (fn, ft) -> + match (snd $3) (fn, ft) with + Some (TPtr(bt, al), m2) -> begin + match (snd $2) al with + Some m1 -> Some (bt, m1 @ m2) + | _ -> None + end + | _ -> None)) + } + +| direct_decl { $1 } +; + +direct_decl: +| /* empty */ { ((fun ts args -> ("", ts, [])), + + (* Match any name in this case *) + (fun (fn, ft) -> + Some (unrollType ft, []))) + } + +| IDENT { ((fun ts args -> ($1, ts, [])), + + (fun (fn, ft) -> + if fn = "" || fn = $1 then + Some (unrollType ft, []) + else + None)) + } + +| LPAREN attributes decl RPAREN + { ((fun ts args -> + let al = (fst $2) args in + (fst $3) (typeAddAttributes al ts) args), + + (fun (fn, ft) -> begin + match (snd $3) (fn, ft) with + Some (restt, m2) -> begin + match (snd $2) (typeAttrs restt) with + Some m1 -> Some (restt, m1 @ m2) + | _ -> None + end + | _ -> None + end)) + } + +| direct_decl LBRACKET exp_opt RBRACKET + { ((fun ts args -> + (fst $1) (TArray(ts, (fst $3) args, [])) args), + + (fun (fn, ft) -> + match (snd $1) (fn, ft) with + Some (TArray(bt, lo, _), m1) -> begin + match (snd $3) lo with + Some m2 -> Some (unrollType bt, m1 @ m2) + | _ -> None + end + | _ -> None)) + } + + +/*(* We use parentheses around the function to avoid conflicts *)*/ +| LPAREN attributes decl RPAREN LPAREN parameters RPAREN + { ((fun ts args -> + let al = (fst $2) args in + let pars, isva = (fst $6) args in + (fst $3) (TFun(ts, pars, isva, al)) args), + + (fun (fn, ft) -> + match (snd $3) (fn, ft) with + Some (TFun(rt, args, isva, al), m1) -> begin + match (snd $2) al, (snd $6) (args, isva) with + Some m2, Some m6 + -> Some (unrollType rt, m1 @ m2 @ m6) + | _ -> None + end + | _ -> None)) + } +; + +parameters: +| /* empty */ { ((fun args -> (None, false)), + + (* Match any formals *) + (fun (pars, isva) -> + match pars, isva with + (_, false) -> Some [] + | _ -> None)) + } + +| parameters_ne { ((fun args -> + let (pars : (string * typ * attributes) list), + (isva : bool) = (fst $1) args in + (Some pars), isva), + + (function + ((Some pars), isva) -> (snd $1) (pars, isva) + | _ -> None)) + } +; +parameters_ne: +| ELLIPSIS + { ((fun args -> ([], true)), + + (function + ([], true) -> Some [] + | _ -> None)) + } + +| ARG_va { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + Fva isva -> ([], isva) + | a -> wrongArgType currentArg "vararg" a), + + (function + ([], isva) -> Some [ Fva isva ] + | _ -> None)) + } + +| ARG_F { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + FF fl -> ( fl, false) + | a -> wrongArgType currentArg "formals" a), + + (function + (pars, false) -> Some [ FF pars ] + | _ -> None)) + } + +| one_formal { ((fun args -> ([(fst $1) args], false)), + + (function + ([ f ], false) -> (snd $1) f + | _ -> None)) + } + + +| one_formal COMMA parameters_ne + { ((fun args -> + let this = (fst $1) args in + let (rest, isva) = (fst $3) args in + (this :: rest, isva)), + + (function + ((f::rest, isva)) -> begin + match (snd $1) f, (snd $3) (rest, isva) with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None + end + | _ -> None)) + } +; + + + + + +exp_opt: + /* empty */ { ((fun args -> None), + (* Match anything if the pattern does not have a len *) + (fun _ -> Some [])) } + +| expression { ((fun args -> Some ((fst $1) args)), + + (fun lo -> match lo with + Some e -> (snd $1) e + | _ -> None)) + } +| ARG_eo { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + Feo lo -> lo + | a -> wrongArgType currentArg "exp_opt" a), + + fun lo -> Some [ Feo lo ]) + } +; + + + +attributes: + /*(* Ignore other attributes *)*/ + /* empty */ { ((fun args -> []), + (fun attrs -> Some [])) } + +| ARG_A { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + FA al -> al + | a -> wrongArgType currentArg "attributes" a), + + (fun al -> Some [ FA al ])) + } + +| attribute attributes + { ((fun args -> + addAttribute ((fst $1) args) ((fst $2) args)), + (* Pass all the attributes down *) + (fun attrs -> + match (snd $1) attrs, (snd $2) attrs with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None)) + } +; + +attribute: +| CONST { doAttr "const" None } +| RESTRICT { doAttr "restrict" None } +| VOLATILE { doAttr "volatile" None } +| ATTRIBUTE LPAREN LPAREN attr RPAREN RPAREN + { $4 } + +; + + +attr: +| IDENT + { doAttr $1 None } + +| IDENT LPAREN attr_args_ne RPAREN + { doAttr $1 (Some $3) } +; + +attr_args_ne: + attr_arg { ((fun args -> [ (fst $1) args ]), + + (fun aargs -> match aargs with + [ arg ] -> (snd $1) arg + | _ -> None)) + } +| attr_arg COMMA attr_args_ne { ((fun args -> + let this = (fst $1) args in + this :: ((fst $3) args)), + + (fun aargs -> match aargs with + h :: rest -> begin + match (snd $1) h, (snd $3) rest with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None + end + | _ -> None)) + } +| ARG_P { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + FP al -> al + | a -> wrongArgType currentArg "attrparams" a), + + (fun al -> Some [ FP al ])) + } +; + +attr_arg: +| IDENT { ((fun args -> ACons($1, [])), + + (fun aarg -> match aarg with + ACons(id, []) when id = $1 -> Some [] + | _ -> None)) + } +| IDENT LPAREN attr_args_ne RPAREN + { ((fun args -> ACons($1, (fst $3) args)), + + (fun aarg -> match aarg with + ACons(id, args) when id = $1 -> + (snd $3) args + | _ -> None)) + } +| ARG_p { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + Fp p -> p + | a -> wrongArgType currentArg "attrparam" a), + + (fun ap -> Some [ Fp ap])) + } + +; + +/* (********** INSTRUCTIONS ***********) */ +instr: +| ARG_i SEMICOLON + { let currentArg = $1 in + ((fun loc args -> + match getArg currentArg args with + Fi i -> i + | a -> wrongArgType currentArg "instr" a), + + (fun i -> Some [ Fi i])) + } + +| lval EQ expression SEMICOLON + { ((fun loc args -> + Set((fst $1) args, (fst $3) args, loc)), + + (fun i -> match i with + Set (lv, e, l) -> begin + match (snd $1) lv, (snd $3) e with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None + end + | _ -> None)) + } + +| lval PLUS_EQ expression SEMICOLON + { ((fun loc args -> + let l = (fst $1) args in + Set(l, buildPlus (Lval l) ((fst $3) args), loc)), + + matchBinopEq + (fun bop -> bop = PlusPI || bop = PlusA) + (snd $1) (snd $3)) + } + +| lval MINUS_EQ expression SEMICOLON + { ((fun loc args -> + let l = (fst $1) args in + Set(l, + buildMinus (Lval l) ((fst $3) args), loc)), + + matchBinopEq (fun bop -> bop = MinusA + || bop = MinusPP + || bop = MinusPI) + (snd $1) (snd $3)) + } +| lval STAR_EQ expression SEMICOLON + { doBinopEq Mult $1 $3 } + +| lval SLASH_EQ expression SEMICOLON + { doBinopEq Div $1 $3 } + +| lval PERCENT_EQ expression SEMICOLON + { doBinopEq Mod $1 $3 } + +| lval AND_EQ expression SEMICOLON + { doBinopEq BAnd $1 $3 } + +| lval PIPE_EQ expression SEMICOLON + { doBinopEq BOr $1 $3 } + +| lval CIRC_EQ expression SEMICOLON + { doBinopEq BXor $1 $3 } + +| lval INF_INF_EQ expression SEMICOLON + { doBinopEq Shiftlt $1 $3 } + +| lval SUP_SUP_EQ expression SEMICOLON + { doBinopEq Shiftrt $1 $3 } + +/* (* Would be nice to be able to condense the next three rules but we get + * into conflicts *)*/ +| lval EQ lval LPAREN arguments RPAREN SEMICOLON + { ((fun loc args -> + Call(Some ((fst $1) args), Lval ((fst $3) args), + (fst $5) args, loc)), + + (fun i -> match i with + Call(Some l, Lval f, args, loc) -> begin + match (snd $1) l, (snd $3) f, (snd $5) args with + Some m1, Some m2, Some m3 -> + Some (m1 @ m2 @ m3) + | _, _, _ -> None + end + | _ -> None)) + } + +| lval LPAREN arguments RPAREN SEMICOLON + { ((fun loc args -> + Call(None, Lval ((fst $1) args), + (fst $3) args, loc)), + + (fun i -> match i with + Call(None, Lval f, args, loc) -> begin + match (snd $1) f, (snd $3) args with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None + end + | _ -> None)) + } + +| arglo lval LPAREN arguments RPAREN SEMICOLON + { ((fun loc args -> + Call((fst $1) args, Lval ((fst $2) args), + (fst $4) args, loc)), + + (fun i -> match i with + Call(lo, Lval f, args, loc) -> begin + match (snd $1) lo, (snd $2) f, (snd $4) args with + Some m1, Some m2, Some m3 -> + Some (m1 @ m2 @ m3) + | _, _, _ -> None + end + | _ -> None)) + } +; + +/* (* Separate this out to ensure that the counting or arguments is right *)*/ +arglo: + ARG_lo { let currentArg = $1 in + ((fun args -> + let res = + match getArg currentArg args with + Flo x -> x + | a -> wrongArgType currentArg "lval option" a + in + res), + + (fun lo -> Some [ Flo lo ])) + } +; +arguments: + /* empty */ { ((fun args -> []), + + (fun actuals -> match actuals with + [] -> Some [] + | _ -> None)) + } + +| arguments_ne { $1 } +; + +arguments_ne: + expression { ((fun args -> [ (fst $1) args ]), + + (fun actuals -> match actuals with + [ h ] -> (snd $1) h + | _ -> None)) + } + +| ARG_E { let currentArg = $1 in + ((fun args -> + match getArg currentArg args with + FE el -> el + | a -> wrongArgType currentArg "arguments" a), + + (fun actuals -> Some [ FE actuals ])) + } + +| expression COMMA arguments_ne + { ((fun args -> ((fst $1) args) :: ((fst $3) args)), + + (fun actuals -> match actuals with + h :: rest -> begin + match (snd $1) h, (snd $3) rest with + Some m1, Some m2 -> Some (m1 @ m2) + | _, _ -> None + end + | _ -> None)) + } +; + + +/*(******** STATEMENTS *********)*/ +stmt: + IF LPAREN expression RPAREN stmt %prec IF + { (fun mkTemp loc args -> + mkStmt (If((fst $3) args, + mkBlock [ $5 mkTemp loc args ], + mkBlock [], loc))) + } +| IF LPAREN expression RPAREN stmt ELSE stmt + { (fun mkTemp loc args -> + mkStmt (If((fst $3) args, + mkBlock [ $5 mkTemp loc args ], + mkBlock [ $7 mkTemp loc args], loc))) + } +| RETURN exp_opt SEMICOLON + { (fun mkTemp loc args -> + mkStmt (Return((fst $2) args, loc))) + } +| BREAK SEMICOLON + { (fun mkTemp loc args -> + mkStmt (Break loc)) + } +| CONTINUE SEMICOLON + { (fun mkTemp loc args -> + mkStmt (Continue loc)) + } +| LBRACE stmt_list RBRACE + { (fun mkTemp loc args -> + let stmts = $2 mkTemp loc args in + mkStmt (Block (mkBlock (stmts)))) + } +| WHILE LPAREN expression RPAREN stmt + { (fun mkTemp loc args -> + let e = (fst $3) args in + let e = + if isPointerType(typeOf e) then + mkCast e !upointType + else e + in +(* + mkStmt + (Loop (mkBlock [ mkStmt + (If(e, + mkBlock [], + mkBlock [ mkStmt + (Break loc) ], + loc)); + $5 mkTemp loc args ], + loc, None, None)) +*) + mkStmt + (While (e, mkBlock [ $5 mkTemp loc args ], loc))) + } +| instr_list { (fun mkTemp loc args -> + mkStmt (Instr ($1 loc args))) + } +| ARG_s { let currentArg = $1 in + (fun mkTemp loc args -> + match getArg currentArg args with + Fs s -> s + | a -> wrongArgType currentArg "stmt" a) } +; + +stmt_list: + /* empty */ { (fun mkTemp loc args -> []) } + +| ARG_S { let currentArg = $1 in + (fun mkTemp loc args -> + match getArg currentArg args with + | FS sl -> sl + | a -> wrongArgType currentArg "stmts" a) + } +| stmt stmt_list + { (fun mkTemp loc args -> + let this = $1 mkTemp loc args in + this :: ($2 mkTemp loc args)) + } +/* (* We can also have a declaration *) */ +| type_spec attributes decl maybe_init SEMICOLON stmt_list + { (fun mkTemp loc args -> + let tal = (fst $2) args in + let ts = (fst $1) tal args in + let (n, t, _) = (fst $3) ts args in + let init = $4 args in + (* Before we proceed we must create the variable *) + let v = mkTemp n t in + (* Now we parse the rest *) + let rest = $6 mkTemp loc ((n, Fv v) :: args) in + (* Now we add the initialization instruction to the + * front *) + match init with + NoInit -> rest + | InitExp e -> + mkStmtOneInstr (Set((Var v, NoOffset), e, loc)) + :: rest + | InitCall (f, args) -> + mkStmtOneInstr (Call(Some (Var v, NoOffset), + Lval f, args, loc)) + :: rest + + ) + } +; + +instr_list: + /*(* Set this rule to very low precedence to ensure that we shift as + many instructions as possible *)*/ + instr %prec COMMA + { (fun loc args -> [ ((fst $1) loc args) ]) } +| ARG_I { let currentArg = $1 in + (fun loc args -> + match getArg currentArg args with + | FI il -> il + | a -> wrongArgType currentArg "instrs" a) + } +| instr instr_list + { (fun loc args -> + let this = (fst $1) loc args in + this :: ($2 loc args)) + } +; + + +maybe_init: +| { (fun args -> NoInit) } +| EQ expression { (fun args -> InitExp ((fst $2) args)) } +| EQ lval LPAREN arguments RPAREN + { (fun args -> + InitCall((fst $2) args, (fst $4) args)) } +; +%% + + + + + + + diff --git a/cil/src/frontc/cabs.ml b/cil/src/frontc/cabs.ml new file mode 100644 index 0000000..78ac02f --- /dev/null +++ b/cil/src/frontc/cabs.ml @@ -0,0 +1,396 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(** This file was originally part of Hugues Casee's frontc 2.0, and has been + * extensively changed since. +** +** 1.0 3.22.99 Hugues Cassé First version. +** 2.0 George Necula 12/12/00: Many extensions + **) + +(* +** Types +*) + +type cabsloc = { + lineno : int; + filename: string; + byteno: int; +} + +let cabslu = {lineno = -10; + filename = "cabs loc unknown"; + byteno = -10;} + +(* clexer puts comments here *) +let commentsGA = GrowArray.make 100 (GrowArray.Elem(cabslu,"",false)) + +type typeSpecifier = (* Merge all specifiers into one type *) + Tvoid (* Type specifier ISO 6.7.2 *) + | Tchar + | Tshort + | Tint + | Tlong + | Tint64 + | Tfloat + | Tdouble + | Tsigned + | Tunsigned + | Tnamed of string + (* each of the following three kinds of specifiers contains a field + * or item list iff it corresponds to a definition (as opposed to + * a forward declaration or simple reference to the type); they + * also have a list of __attribute__s that appeared between the + * keyword and the type name (definitions only) *) + | Tstruct of string * field_group list option * attribute list + | Tunion of string * field_group list option * attribute list + | Tenum of string * enum_item list option * attribute list + | TtypeofE of expression (* GCC __typeof__ *) + | TtypeofT of specifier * decl_type (* GCC __typeof__ *) + +and storage = + NO_STORAGE | AUTO | STATIC | EXTERN | REGISTER + +and funspec = + INLINE | VIRTUAL | EXPLICIT + +and cvspec = + CV_CONST | CV_VOLATILE | CV_RESTRICT + +(* Type specifier elements. These appear at the start of a declaration *) +(* Everywhere they appear in this file, they appear as a 'spec_elem list', *) +(* which is not interpreted by cabs -- rather, this "word soup" is passed *) +(* on to the compiler. Thus, we can represent e.g. 'int long float x' even *) +(* though the compiler will of course choke. *) +and spec_elem = + SpecTypedef + | SpecCV of cvspec (* const/volatile *) + | SpecAttr of attribute (* __attribute__ *) + | SpecStorage of storage + | SpecInline + | SpecType of typeSpecifier + | SpecPattern of string (* specifier pattern variable *) + +(* decided to go ahead and replace 'spec_elem list' with specifier *) +and specifier = spec_elem list + + +(* Declarator type. They modify the base type given in the specifier. Keep + * them in the order as they are printed (this means that the top level + * constructor for ARRAY and PTR is the inner-level in the meaning of the + * declared type) *) +and decl_type = + | JUSTBASE (* Prints the declared name *) + | PARENTYPE of attribute list * decl_type * attribute list + (* Prints "(attrs1 decl attrs2)". + * attrs2 are attributes of the + * declared identifier and it is as + * if they appeared at the very end + * of the declarator. attrs1 can + * contain attributes for the + * identifier or attributes for the + * enclosing type. *) + | ARRAY of decl_type * attribute list * expression + (* Prints "decl [ attrs exp ]". + * decl is never a PTR. *) + | PTR of attribute list * decl_type (* Prints "* attrs decl" *) + | PROTO of decl_type * single_name list * bool + (* Prints "decl (args[, ...])". + * decl is never a PTR.*) + +(* The base type and the storage are common to all names. Each name might + * contain type or storage modifiers *) +(* e.g.: int x, y; *) +and name_group = specifier * name list + +(* The optional expression is the bitfield *) +and field_group = specifier * (name * expression option) list + +(* like name_group, except the declared variables are allowed to have initializers *) +(* e.g.: int x=1, y=2; *) +and init_name_group = specifier * init_name list + +(* The decl_type is in the order in which they are printed. Only the name of + * the declared identifier is pulled out. The attributes are those that are + * printed after the declarator *) +(* e.g: in "int *x", "*x" is the declarator; "x" will be pulled out as *) +(* the string, and decl_type will be PTR([], JUSTBASE) *) +and name = string * decl_type * attribute list * cabsloc + +(* A variable declarator ("name") with an initializer *) +and init_name = name * init_expression + +(* Single names are for declarations that cannot come in groups, like + * function parameters and functions *) +and single_name = specifier * name + + +and enum_item = string * expression * cabsloc + +(* +** Declaration definition (at toplevel) +*) +and definition = + FUNDEF of single_name * block * cabsloc * cabsloc + | DECDEF of init_name_group * cabsloc (* global variable(s), or function prototype *) + | TYPEDEF of name_group * cabsloc + | ONLYTYPEDEF of specifier * cabsloc + | GLOBASM of string * cabsloc + | PRAGMA of expression * cabsloc + | LINKAGE of string * cabsloc * definition list (* extern "C" { ... } *) + (* toplevel form transformer, from the first definition to the *) + (* second group of definitions *) + | TRANSFORMER of definition * definition list * cabsloc + (* expression transformer: source and destination *) + | EXPRTRANSFORMER of expression * expression * cabsloc + + +(* the string is a file name, and then the list of toplevel forms *) +and file = string * definition list + + +(* +** statements +*) + +(* A block contains a list of local label declarations ( GCC's ({ __label__ + * l1, l2; ... }) ) , a list of definitions and a list of statements *) +and block = + { blabels: string list; + battrs: attribute list; + bstmts: statement list + } + +(* GCC asm directives have lots of extra information to guide the optimizer *) +and asm_details = + { aoutputs: (string * expression) list; (* constraints and expressions for outputs *) + ainputs: (string * expression) list; (* constraints and expressions for inputs *) + aclobbers: string list (* clobbered registers *) + } + +and statement = + NOP of cabsloc + | COMPUTATION of expression * cabsloc + | BLOCK of block * cabsloc + | SEQUENCE of statement * statement * cabsloc + | IF of expression * statement * statement * cabsloc + | WHILE of expression * statement * cabsloc + | DOWHILE of expression * statement * cabsloc + | FOR of for_clause * expression * expression * statement * cabsloc + | BREAK of cabsloc + | CONTINUE of cabsloc + | RETURN of expression * cabsloc + | SWITCH of expression * statement * cabsloc + | CASE of expression * statement * cabsloc + | CASERANGE of expression * expression * statement * cabsloc + | DEFAULT of statement * cabsloc + | LABEL of string * statement * cabsloc + | GOTO of string * cabsloc + | COMPGOTO of expression * cabsloc (* GCC's "goto *exp" *) + | DEFINITION of definition (*definition or declaration of a variable or type*) + + | ASM of attribute list * (* typically only volatile and const *) + string list * (* template *) + asm_details option * (* extra details to guide GCC's optimizer *) + cabsloc + + (** MS SEH *) + | TRY_EXCEPT of block * expression * block * cabsloc + | TRY_FINALLY of block * block * cabsloc + +and for_clause = + FC_EXP of expression + | FC_DECL of definition + +(* +** Expressions +*) +and binary_operator = + ADD | SUB | MUL | DIV | MOD + | AND | OR + | BAND | BOR | XOR | SHL | SHR + | EQ | NE | LT | GT | LE | GE + | ASSIGN + | ADD_ASSIGN | SUB_ASSIGN | MUL_ASSIGN | DIV_ASSIGN | MOD_ASSIGN + | BAND_ASSIGN | BOR_ASSIGN | XOR_ASSIGN | SHL_ASSIGN | SHR_ASSIGN + +and unary_operator = + MINUS | PLUS | NOT | BNOT | MEMOF | ADDROF + | PREINCR | PREDECR | POSINCR | POSDECR + +and expression = + NOTHING + | UNARY of unary_operator * expression + | LABELADDR of string (* GCC's && Label *) + | BINARY of binary_operator * expression * expression + | QUESTION of expression * expression * expression + + (* A CAST can actually be a constructor expression *) + | CAST of (specifier * decl_type) * init_expression + + (* There is a special form of CALL in which the function called is + __builtin_va_arg and the second argument is sizeof(T). This + should be printed as just T *) + | CALL of expression * expression list + | COMMA of expression list + | CONSTANT of constant + | VARIABLE of string + | EXPR_SIZEOF of expression + | TYPE_SIZEOF of specifier * decl_type + | EXPR_ALIGNOF of expression + | TYPE_ALIGNOF of specifier * decl_type + | INDEX of expression * expression + | MEMBEROF of expression * string + | MEMBEROFPTR of expression * string + | GNU_BODY of block + | EXPR_PATTERN of string (* pattern variable, and name *) + +and constant = + | CONST_INT of string (* the textual representation *) + | CONST_FLOAT of string (* the textual representaton *) + | CONST_CHAR of int64 list + | CONST_WCHAR of int64 list + | CONST_STRING of string + | CONST_WSTRING of int64 list + (* ww: wstrings are stored as an int64 list at this point because + * we might need to feed the wide characters piece-wise into an + * array initializer (e.g., wchar_t foo[] = L"E\xabcd";). If that + * doesn't happen we will convert it to an (escaped) string before + * passing it to Cil. *) + +and init_expression = + | NO_INIT + | SINGLE_INIT of expression + | COMPOUND_INIT of (initwhat * init_expression) list + +and initwhat = + NEXT_INIT + | INFIELD_INIT of string * initwhat + | ATINDEX_INIT of expression * initwhat + | ATINDEXRANGE_INIT of expression * expression + + + (* Each attribute has a name and some + * optional arguments *) +and attribute = string * expression list + + +(*********** HELPER FUNCTIONS **********) + +let missingFieldDecl = ("___missing_field_name", JUSTBASE, [], cabslu) + +let rec isStatic = function + [] -> false + | (SpecStorage STATIC) :: _ -> true + | _ :: rest -> isStatic rest + +let rec isExtern = function + [] -> false + | (SpecStorage EXTERN) :: _ -> true + | _ :: rest -> isExtern rest + +let rec isInline = function + [] -> false + | SpecInline :: _ -> true + | _ :: rest -> isInline rest + +let rec isTypedef = function + [] -> false + | SpecTypedef :: _ -> true + | _ :: rest -> isTypedef rest + + +let get_definitionloc (d : definition) : cabsloc = + match d with + | FUNDEF(_, _, l, _) -> l + | DECDEF(_, l) -> l + | TYPEDEF(_, l) -> l + | ONLYTYPEDEF(_, l) -> l + | GLOBASM(_, l) -> l + | PRAGMA(_, l) -> l + | TRANSFORMER(_, _, l) -> l + | EXPRTRANSFORMER(_, _, l) -> l + | LINKAGE (_, l, _) -> l + +let get_statementloc (s : statement) : cabsloc = +begin + match s with + | NOP(loc) -> loc + | COMPUTATION(_,loc) -> loc + | BLOCK(_,loc) -> loc + | SEQUENCE(_,_,loc) -> loc + | IF(_,_,_,loc) -> loc + | WHILE(_,_,loc) -> loc + | DOWHILE(_,_,loc) -> loc + | FOR(_,_,_,_,loc) -> loc + | BREAK(loc) -> loc + | CONTINUE(loc) -> loc + | RETURN(_,loc) -> loc + | SWITCH(_,_,loc) -> loc + | CASE(_,_,loc) -> loc + | CASERANGE(_,_,_,loc) -> loc + | DEFAULT(_,loc) -> loc + | LABEL(_,_,loc) -> loc + | GOTO(_,loc) -> loc + | COMPGOTO (_, loc) -> loc + | DEFINITION d -> get_definitionloc d + | ASM(_,_,_,loc) -> loc + | TRY_EXCEPT(_, _, _, loc) -> loc + | TRY_FINALLY(_, _, loc) -> loc +end + + +let explodeStringToInts (s: string) : int64 list = + let rec allChars i acc = + if i < 0 then acc + else allChars (i - 1) (Int64.of_int (Char.code (String.get s i)) :: acc) + in + allChars (-1 + String.length s) [] + +let valueOfDigit chr = + let int_value = + match chr with + '0'..'9' -> (Char.code chr) - (Char.code '0') + | 'a'..'z' -> (Char.code chr) - (Char.code 'a') + 10 + | 'A'..'Z' -> (Char.code chr) - (Char.code 'A') + 10 + | _ -> Errormsg.s (Errormsg.bug "not a digit") in + Int64.of_int int_value + + +open Pretty +let d_cabsloc () cl = + text cl.filename ++ text ":" ++ num cl.lineno diff --git a/cil/src/frontc/cabs2cil.ml b/cil/src/frontc/cabs2cil.ml new file mode 100644 index 0000000..31b65b5 --- /dev/null +++ b/cil/src/frontc/cabs2cil.ml @@ -0,0 +1,6238 @@ +(* MODIF: allow E.Error to propagate *) + +(* MODIF: for pointer comparison, avoid systematic cast to unsigned int *) + +(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) +(* MODIF: Return statement no longer added when the body of the function + falls-through. *) + +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* Type check and elaborate ABS to CIL *) + +(* The references to ISO means ANSI/ISO 9899-1999 *) +module A = Cabs +module E = Errormsg +module H = Hashtbl +module IH = Inthash +module AL = Alpha + +open Cabs +open Pretty +open Cil +open Trace + + +let mydebugfunction () = + E.s (error "mydebugfunction") + +let debugGlobal = false + +(** NDC added command line parameter **) +(* Turn on tranformation that forces correct parameter evaluation order *) +let forceRLArgEval = ref false + +(* Leave a certain global alone. Use a negative number to disable. *) +let nocil: int ref = ref (-1) + +(* Indicates whether we're allowed to duplicate small chunks. *) +let allowDuplication: bool ref = ref true + +(* ---------- source error message handling ------------- *) +let lu = locUnknown +let cabslu = {lineno = -10; + filename = "cabs lu"; + byteno = -10;} + + +(** Interface to the Cprint printer *) +let withCprint (f: 'a -> unit) (x: 'a) : unit = + Cprint.commit (); Cprint.flush (); + let old = !Cprint.out in + Cprint.out := !E.logChannel; + f x; + Cprint.commit (); Cprint.flush (); + flush !Cprint.out; + Cprint.out := old + + +(** Keep a list of the variable ID for the variables that were created to + * hold the result of function calls *) +let callTempVars: unit IH.t = IH.create 13 + +(* Keep a list of functions that were called without a prototype. *) +let noProtoFunctions : bool IH.t = IH.create 13 + +(* Check that s starts with the prefix p *) +let prefix p s = + let lp = String.length p in + let ls = String.length s in + lp <= ls && String.sub s 0 lp = p + +(***** COMPUTED GOTO ************) + +(* The address of labels are small integers (starting from 0). A computed + * goto is replaced with a switch on the address of the label. We generate + * only one such switch and we'll jump to it from all computed gotos. To + * accomplish this we'll add a local variable to store the target of the + * goto. *) + +(* The local variable in which to put the detination of the goto and the + * statement where to jump *) +let gotoTargetData: (varinfo * stmt) option ref = ref None + +(* The "addresses" of labels *) +let gotoTargetHash: (string, int) H.t = H.create 13 +let gotoTargetNextAddr: int ref = ref 0 + + +(********** TRANSPARENT UNION ******) +(* Check if a type is a transparent union, and return the first field if it + * is *) +let isTransparentUnion (t: typ) : fieldinfo option = + match unrollType t with + TComp (comp, _) when not comp.cstruct -> + (* Turn transparent unions into the type of their first field *) + if hasAttribute "transparent_union" (typeAttrs t) then begin + match comp.cfields with + f :: _ -> Some f + | _ -> E.s (unimp "Empty transparent union: %s" (compFullName comp)) + end else + None + | _ -> None + +(* When we process an argument list, remember the argument index which has a + * transparent union type, along with the original type. We need this to + * process function definitions *) +let transparentUnionArgs : (int * typ) list ref = ref [] + +let debugLoc = false +let convLoc (l : cabsloc) = + if debugLoc then + ignore (E.log "convLoc at %s: line %d, btye %d\n" l.filename l.lineno l.byteno); + {line = l.lineno; file = l.filename; byte = l.byteno;} + + +let isOldStyleVarArgName n = + if !msvcMode then n = "va_alist" + else n = "__builtin_va_alist" + +let isOldStyleVarArgTypeName n = + if !msvcMode then n = "va_list" || n = "__ccured_va_list" + else n = "__builtin_va_alist_t" + +(* Weimer + * multi-character character constants + * In MSCV, this code works: + * + * long l1 = 'abcd'; // note single quotes + * char * s = "dcba"; + * long * lptr = ( long * )s; + * long l2 = *lptr; + * assert(l1 == l2); + * + * We need to change a multi-character character literal into the + * appropriate integer constant. However, the plot sickens: we + * must also be able to handle things like 'ab\nd' (value = * "d\nba") + * and 'abc' (vale = *"cba"). + * + * First we convert 'AB\nD' into the list [ 65 ; 66 ; 10 ; 68 ], then we + * multiply and add to get the desired value. + *) + +(* Given a character constant (like 'a' or 'abc') as a list of 64-bit + * values, turn it into a CIL constant. Multi-character constants are + * treated as multi-digit numbers with radix given by the bit width of + * the specified type (either char or wchar_t). *) +let reduce_multichar typ : int64 list -> int64 = + let radix = bitsSizeOf typ in + List.fold_left + (fun acc -> Int64.add (Int64.shift_left acc radix)) + Int64.zero + +let interpret_character_constant char_list = + let value = reduce_multichar charType char_list in + if value < (Int64.of_int 256) then + (* ISO C 6.4.4.4.10: single-character constants have type int *) + (CChr(Char.chr (Int64.to_int value))), intType + else begin + let orig_rep = None (* Some("'" ^ (String.escaped str) ^ "'") *) in + if value <= (Int64.of_int32 Int32.max_int) then + (CInt64(value,IULong,orig_rep)),(TInt(IULong,[])) + else + (CInt64(value,IULongLong,orig_rep)),(TInt(IULongLong,[])) + end + +(*** EXPRESSIONS *************) + + (* We collect here the program *) +let theFile : global list ref = ref [] +let theFileTypes : global list ref = ref [] + +let initGlobals () = theFile := []; theFileTypes := [] + + +let cabsPushGlobal (g: global) = + pushGlobal g ~types:theFileTypes ~variables:theFile + +(* Keep track of some variable ids that must be turned into definitions. We + * do this when we encounter what appears a definition of a global but + * without initializer. We leave it a declaration because maybe down the road + * we see another definition with an initializer. But if we don't see any + * then we turn the last such declaration into a definition without + * initializer *) +let mustTurnIntoDef: bool IH.t = IH.create 117 + +(* Globals that have already been defined. Indexed by the variable name. *) +let alreadyDefined: (string, location) H.t = H.create 117 + +(* Globals that were created due to static local variables. We chose their + * names to be distinct from any global encountered at the time. But we might + * see a global with conflicting name later in the file. *) +let staticLocals: (string, varinfo) H.t = H.create 13 + + +(* Typedefs. We chose their names to be distinct from any global encounterd + * at the time. But we might see a global with conflicting name later in the + * file *) +let typedefs: (string, typeinfo) H.t = H.create 13 + +let popGlobals () = + let rec revonto (tail: global list) = function + [] -> tail + + | GVarDecl (vi, l) :: rest + when vi.vstorage != Extern && IH.mem mustTurnIntoDef vi.vid -> + IH.remove mustTurnIntoDef vi.vid; + revonto (GVar (vi, {init = None}, l) :: tail) rest + + | x :: rest -> revonto (x :: tail) rest + in + revonto (revonto [] !theFile) !theFileTypes + + +(********* ENVIRONMENTS ***************) + +(* The environment is kept in two distinct data structures. A hash table maps + * each original variable name into a varinfo (for variables, or an + * enumeration tag, or a type). (Note that the varinfo might contain an + * alpha-converted name different from that of the lookup name.) The Ocaml + * hash tables can keep multiple mappings for a single key. Each time the + * last mapping is returned and upon deletion the old mapping is restored. To + * keep track of local scopes we also maintain a list of scopes (represented + * as lists). *) +type envdata = + EnvVar of varinfo (* The name refers to a variable + * (which could also be a function) *) + | EnvEnum of exp * typ (* The name refers to an enumeration + * tag for which we know the value + * and the host type *) + | EnvTyp of typ (* The name is of the form "struct + * foo", or "union foo" or "enum foo" + * and refers to a type. Note that + * the name of the actual type might + * be different from foo due to alpha + * conversion *) + | EnvLabel of string (* The name refers to a label. This + * is useful for GCC's locally + * declared labels. The lookup name + * for this category is "label foo" *) + +let env : (string, envdata * location) H.t = H.create 307 +(* We also keep a global environment. This is always a subset of the env *) +let genv : (string, envdata * location) H.t = H.create 307 + + (* In the scope we keep the original name, so we can remove them from the + * hash table easily *) +type undoScope = + UndoRemoveFromEnv of string + | UndoResetAlphaCounter of location AL.alphaTableData ref * + location AL.alphaTableData + | UndoRemoveFromAlphaTable of string + +let scopes : undoScope list ref list ref = ref [] + +let isAtTopLevel () = + !scopes = [] + + +(* When you add to env, you also add it to the current scope *) +let addLocalToEnv (n: string) (d: envdata) = +(* ignore (E.log "%a: adding local %s to env\n" d_loc !currentLoc n); *) + H.add env n (d, !currentLoc); + (* If we are in a scope, then it means we are not at top level. Add the + * name to the scope *) + (match !scopes with + [] -> begin + match d with + EnvVar _ -> + E.s (E.bug "addLocalToEnv: not in a scope when adding %s!" n) + | _ -> () (* We might add types *) + end + | s :: _ -> + s := (UndoRemoveFromEnv n) :: !s) + + +let addGlobalToEnv (k: string) (d: envdata) : unit = +(* ignore (E.log "%a: adding global %s to env\n" d_loc !currentLoc k); *) + H.add env k (d, !currentLoc); + (* Also add it to the global environment *) + H.add genv k (d, !currentLoc) + + + +(* Create a new name based on a given name. The new name is formed from a + * prefix (obtained from the given name as the longest prefix that ends with + * a non-digit), followed by a '_' and then by a positive integer suffix. The + * first argument is a table mapping name prefixes with the largest suffix + * used so far for that prefix. The largest suffix is one when only the + * version without suffix has been used. *) +let alphaTable : (string, location AL.alphaTableData ref) H.t = H.create 307 + (* vars and enum tags. For composite types we have names like "struct + * foo" or "union bar" *) + +(* To keep different name scopes different, we add prefixes to names + * specifying the kind of name: the kind can be one of "" for variables or + * enum tags, "struct" for structures and unions (they share the name space), + * "enum" for enumerations, or "type" for types *) +let kindPlusName (kind: string) + (origname: string) : string = + if kind = "" then origname else + kind ^ " " ^ origname + + +let stripKind (kind: string) (kindplusname: string) : string = + let l = 1 + String.length kind in + if l > 1 then + String.sub kindplusname l (String.length kindplusname - l) + else + kindplusname + +let newAlphaName (globalscope: bool) (* The name should have global scope *) + (kind: string) + (origname: string) : string * location = + let lookupname = kindPlusName kind origname in + (* If we are in a scope then it means that we are alpha-converting a local + * name. Go and add stuff to reset the state of the alpha table but only to + * the top-most scope (that of the enclosing function) *) + let rec findEnclosingFun = function + [] -> (* At global scope *)() + | [s] -> begin + let prefix = AL.getAlphaPrefix lookupname in + try + let countref = H.find alphaTable prefix in + s := (UndoResetAlphaCounter (countref, !countref)) :: !s + with Not_found -> + s := (UndoRemoveFromAlphaTable prefix) :: !s + end + | _ :: rest -> findEnclosingFun rest + in + if not globalscope then + findEnclosingFun !scopes; + let newname, oldloc = + AL.newAlphaName alphaTable None lookupname !currentLoc in + stripKind kind newname, oldloc + + + + +let explodeString (nullterm: bool) (s: string) : char list = + let rec allChars i acc = + if i < 0 then acc + else allChars (i - 1) ((String.get s i) :: acc) + in + allChars (-1 + String.length s) + (if nullterm then [Char.chr 0] else []) + +(*** In order to process GNU_BODY expressions we must record that a given + *** COMPUTATION is interesting *) +let gnu_body_result : (A.statement * ((exp * typ) option ref)) ref + = ref (A.NOP cabslu, ref None) + +(*** When we do statements we need to know the current return type *) +let currentReturnType : typ ref = ref (TVoid([])) +let currentFunctionFDEC: fundec ref = ref dummyFunDec + + +let lastStructId = ref 0 +let anonStructName (k: string) (suggested: string) = + incr lastStructId; + "__anon" ^ k ^ (if suggested <> "" then "_" ^ suggested else "") + ^ "_" ^ (string_of_int (!lastStructId)) + + +let constrExprId = ref 0 + + +let startFile () = + H.clear env; + H.clear genv; + H.clear alphaTable; + lastStructId := 0 + + + +let enterScope () = + scopes := (ref []) :: !scopes + + (* Exit a scope and clean the environment. We do not yet delete from + * the name table *) +let exitScope () = + let this, rest = + match !scopes with + car :: cdr -> car, cdr + | [] -> E.s (error "Not in a scope") + in + scopes := rest; + let rec loop = function + [] -> () + | UndoRemoveFromEnv n :: t -> + H.remove env n; loop t + | UndoRemoveFromAlphaTable n :: t -> H.remove alphaTable n; loop t + | UndoResetAlphaCounter (vref, oldv) :: t -> + vref := oldv; + loop t + in + loop !this + +(* Lookup a variable name. Return also the location of the definition. Might + * raise Not_found *) +let lookupVar (n: string) : varinfo * location = + match H.find env n with + (EnvVar vi), loc -> vi, loc + | _ -> raise Not_found + +let lookupGlobalVar (n: string) : varinfo * location = + match H.find genv n with + (EnvVar vi), loc -> vi, loc + | _ -> raise Not_found + +let docEnv () = + let acc : (string * (envdata * location)) list ref = ref [] in + let doone () = function + EnvVar vi, l -> + dprintf "Var(%s,global=%b) (at %a)" vi.vname vi.vglob d_loc l + | EnvEnum (tag, typ), l -> dprintf "Enum (at %a)" d_loc l + | EnvTyp t, l -> text "typ" + | EnvLabel l, _ -> text ("label " ^ l) + in + H.iter (fun k d -> acc := (k, d) :: !acc) env; + docList ~sep:line (fun (k, d) -> dprintf " %s -> %a" k doone d) () !acc + + + +(* Add a new variable. Do alpha-conversion if necessary *) +let alphaConvertVarAndAddToEnv (addtoenv: bool) (vi: varinfo) : varinfo = +(* + ignore (E.log "%t: alphaConvert(addtoenv=%b) %s" d_thisloc addtoenv vi.vname); +*) + (* Announce the name to the alpha conversion table *) + let newname, oldloc = newAlphaName (addtoenv && vi.vglob) "" vi.vname in + (* Make a copy of the vi if the name has changed. Never change the name for + * global variables *) + let newvi = + if vi.vname = newname then + vi + else begin + if vi.vglob then begin + (* Perhaps this is because we have seen a static local which happened + * to get the name that we later want to use for a global. *) + try + let static_local_vi = H.find staticLocals vi.vname in + H.remove staticLocals vi.vname; + (* Use the new name for the static local *) + static_local_vi.vname <- newname; + (* And continue using the last one *) + vi + with Not_found -> begin + (* Or perhaps we have seen a typedef which stole our name. This is + possible because typedefs use the same name space *) + try + let typedef_ti = H.find typedefs vi.vname in + H.remove typedefs vi.vname; + (* Use the new name for the typedef instead *) + typedef_ti.tname <- newname; + (* And continue using the last name *) + vi + with Not_found -> + E.s (E.error "It seems that we would need to rename global %s (to %s) because of previous occurrence at %a" + vi.vname newname d_loc oldloc); + end + end else begin + (* We have changed the name of a local variable. Can we try to detect + * if the other variable was also local in the same scope? Not for + * now. *) + copyVarinfo vi newname + end + end + in + (* Store all locals in the slocals (in reversed order). We'll reverse them + * and take out the formals at the end of the function *) + if not vi.vglob then + !currentFunctionFDEC.slocals <- newvi :: !currentFunctionFDEC.slocals; + + (if addtoenv then + if vi.vglob then + addGlobalToEnv vi.vname (EnvVar newvi) + else + addLocalToEnv vi.vname (EnvVar newvi)); +(* + ignore (E.log " new=%s\n" newvi.vname); +*) +(* ignore (E.log "After adding %s alpha table is: %a\n" + newvi.vname docAlphaTable alphaTable); *) + newvi + + +(* Strip the "const" from the type. It is unfortunate that const variables + * can only be set in initialization. Once we decided to move all + * declarations to the top of the functions, we have no way of setting a + * "const" variable. Furthermore, if the type of the variable is an array or + * a struct we must recursively strip the "const" from fields and array + * elements. *) +let rec stripConstLocalType (t: typ) : typ = + let dc a = + if hasAttribute "const" a then + dropAttribute "const" a + else a + in + match t with + | TPtr (bt, a) -> + (* We want to be able to detect by pointer equality if the type has + * changed. So, don't realloc the type unless necessary. *) + let a' = dc a in if a != a' then TPtr(bt, a') else t + | TInt (ik, a) -> + let a' = dc a in if a != a' then TInt(ik, a') else t + | TFloat(fk, a) -> + let a' = dc a in if a != a' then TFloat(fk, a') else t + | TNamed (ti, a) -> + (* We must go and drop the consts from the typeinfo as well ! *) + let t' = stripConstLocalType ti.ttype in + if t != t' then begin + (* ignore (warn "Stripping \"const\" from typedef %s\n" ti.tname); *) + ti.ttype <- t' + end; + let a' = dc a in if a != a' then TNamed(ti, a') else t + + | TEnum (ei, a) -> + let a' = dc a in if a != a' then TEnum(ei, a') else t + + | TArray(bt, leno, a) -> + (* We never assign to the array. So, no need to change the const. But + * we must change it on the base type *) + let bt' = stripConstLocalType bt in + if bt' != bt then TArray(bt', leno, a) else t + + | TComp(ci, a) -> + (* Must change both this structure as well as its fields *) + List.iter + (fun f -> + let t' = stripConstLocalType f.ftype in + if t' != f.ftype then begin + ignore (warnOpt "Stripping \"const\" from field %s of %s\n" + f.fname (compFullName ci)); + f.ftype <- t' + end) + ci.cfields; + let a' = dc a in if a != a' then TComp(ci, a') else t + + (* We never assign functions either *) + | TFun(rt, args, va, a) -> t + | TVoid _ -> E.s (bug "cabs2cil: stripConstLocalType: void") + | TBuiltin_va_list a -> + let a' = dc a in if a != a' then TBuiltin_va_list a' else t + + +let constFoldTypeVisitor = object (self) + inherit nopCilVisitor + method vtype t: typ visitAction = + match t with + TArray(bt, Some len, a) -> + let len' = constFold true len in + ChangeDoChildrenPost ( + TArray(bt, Some len', a), + (fun x -> x) + ) + | _ -> DoChildren +end + +(* Const-fold any expressions that appear as array lengths in this type *) +let constFoldType (t:typ) : typ = + visitCilType constFoldTypeVisitor t + + + +(* Create a new temporary variable *) +let newTempVar typ = + if !currentFunctionFDEC == dummyFunDec then + E.s (bug "newTempVar called outside a function"); +(* ignore (E.log "stripConstLocalType(%a) for temporary\n" d_type typ); *) + let t' = stripConstLocalType typ in + (* Start with the name "tmp". The alpha converter will fix it *) + let vi = makeVarinfo false "tmp" t' in + alphaConvertVarAndAddToEnv false vi (* Do not add to the environment *) +(* + { vname = "tmp"; (* addNewVar will make the name fresh *) + vid = newVarId "tmp" false; + vglob = false; + vtype = t'; + vdecl = locUnknown; + vinline = false; + vattr = []; + vaddrof = false; + vreferenced = false; (* sm *) + vstorage = NoStorage; + } +*) + +let mkAddrOfAndMark ((b, off) as lval) : exp = + (* Mark the vaddrof flag if b is a variable *) + (match b with + Var vi -> vi.vaddrof <- true + | _ -> ()); + mkAddrOf lval + +(* Call only on arrays *) +let mkStartOfAndMark ((b, off) as lval) : exp = + (* Mark the vaddrof flag if b is a variable *) + (match b with + Var vi -> vi.vaddrof <- true + | _ -> ()); + let res = StartOf lval in + res + + + + (* Keep a set of self compinfo for composite types *) +let compInfoNameEnv : (string, compinfo) H.t = H.create 113 +let enumInfoNameEnv : (string, enuminfo) H.t = H.create 113 + + +let lookupTypeNoError (kind: string) + (n: string) : typ * location = + let kn = kindPlusName kind n in + match H.find env kn with + EnvTyp t, l -> t, l + | _ -> raise Not_found + +let lookupType (kind: string) + (n: string) : typ * location = + try + lookupTypeNoError kind n + with Not_found -> + E.s (error "Cannot find type %s (kind:%s)\n" n kind) + +(* Create the self ref cell and add it to the map. Return also an indication + * if this is a new one. *) +let createCompInfo (iss: bool) (n: string) : compinfo * bool = + (* Add to the self cell set *) + let key = (if iss then "struct " else "union ") ^ n in + try + H.find compInfoNameEnv key, false (* Only if not already in *) + with Not_found -> begin + (* Create a compinfo. This will have "cdefined" false. *) + let res = mkCompInfo iss n (fun _ -> []) [] in + H.add compInfoNameEnv key res; + res, true + end + +(* Create the self ref cell and add it to the map. Return an indication + * whether this is a new one. *) +let createEnumInfo (n: string) : enuminfo * bool = + (* Add to the self cell set *) + try + H.find enumInfoNameEnv n, false (* Only if not already in *) + with Not_found -> begin + (* Create a enuminfo *) + let enum = { ename = n; eitems = []; + eattr = []; ereferenced = false; } in + H.add enumInfoNameEnv n enum; + enum, true + end + + + (* kind is either "struct" or "union" or "enum" and n is a name *) +let findCompType (kind: string) (n: string) (a: attributes) = + let makeForward () = + (* This is a forward reference, either because we have not seen this + * struct already or because we want to create a version with different + * attributes *) + if kind = "enum" then + let enum, isnew = createEnumInfo n in + if isnew then + cabsPushGlobal (GEnumTagDecl (enum, !currentLoc)); + TEnum (enum, a) + else + let iss = if kind = "struct" then true else false in + let self, isnew = createCompInfo iss n in + if isnew then + cabsPushGlobal (GCompTagDecl (self, !currentLoc)); + TComp (self, a) + in + try + let old, _ = lookupTypeNoError kind n in (* already defined *) + let olda = typeAttrs old in + if Util.equals olda a then old else makeForward () + with Not_found -> makeForward () + + +(* A simple visitor that searchs a statement for labels *) +class canDropStmtClass pRes = object + inherit nopCilVisitor + + method vstmt s = + if s.labels != [] then + (pRes := false; SkipChildren) + else + if !pRes then DoChildren else SkipChildren + + method vinst _ = SkipChildren + method vexpr _ = SkipChildren + +end +let canDropStatement (s: stmt) : bool = + let pRes = ref true in + let vis = new canDropStmtClass pRes in + ignore (visitCilStmt vis s); + !pRes + +(**** Occasionally we see structs with no name and no fields *) + + +module BlockChunk = + struct + type chunk = { + stmts: stmt list; + postins: instr list; (* Some instructions to append at + * the ends of statements (in + * reverse order) *) + (* A list of case statements visible at the + * outer level *) + cases: (label * stmt) list + } + + let d_chunk () (c: chunk) = + dprintf "@[{ @[%a@] };@?%a@]" + (docList ~sep:(chr ';') (d_stmt ())) c.stmts + (docList ~sep:(chr ';') (d_instr ())) (List.rev c.postins) + + let empty = + { stmts = []; postins = []; cases = []; } + + let isEmpty (c: chunk) = + c.postins == [] && c.stmts == [] + + let isNotEmpty (c: chunk) = not (isEmpty c) + + let i2c (i: instr) = + { empty with postins = [i] } + + (* Occasionally, we'll have to push postins into the statements *) + let pushPostIns (c: chunk) : stmt list = + if c.postins = [] then c.stmts + else + let rec toLast = function + [{skind=Instr il} as s] as stmts -> + s.skind <- Instr (il @ (List.rev c.postins)); + stmts + + | [] -> [mkStmt (Instr (List.rev c.postins))] + + | a :: rest -> a :: toLast rest + in + compactStmts (toLast c.stmts) + + + let c2block (c: chunk) : block = + { battrs = []; + bstmts = pushPostIns c; + } + + (* Add an instruction at the end. Never refer to this instruction again + * after you call this *) + let (+++) (c: chunk) (i : instr) = + {c with postins = i :: c.postins} + + (* Append two chunks. Never refer to the original chunks after you call + * this. And especially never share c2 with somebody else *) + let (@@) (c1: chunk) (c2: chunk) = + { stmts = compactStmts (pushPostIns c1 @ c2.stmts); + postins = c2.postins; + cases = c1.cases @ c2.cases; + } + + let skipChunk = empty + + let returnChunk (e: exp option) (l: location) : chunk = + { stmts = [ mkStmt (Return(e, l)) ]; + postins = []; + cases = [] + } + + let ifChunk (be: exp) (l: location) (t: chunk) (e: chunk) : chunk = + + { stmts = [ mkStmt(If(be, c2block t, c2block e, l))]; + postins = []; + cases = t.cases @ e.cases; + } + + (* We can duplicate a chunk if it has a few simple statements, and if + * it does not have cases *) + let duplicateChunk (c: chunk) = (* raises Failure if you should not + * duplicate this chunk *) + if not !allowDuplication then + raise (Failure "cannot duplicate: disallowed by user"); + if c.cases != [] then raise (Failure "cannot duplicate: has cases") else + let pCount = ref (List.length c.postins) in + { stmts = + List.map + (fun s -> + if s.labels != [] then + raise (Failure "cannot duplicate: has labels"); +(* + (match s.skind with + If _ | Switch _ | (*Loop _*) + While _ | DoWhile _ | For _ | Block _ -> + raise (Failure "cannot duplicate: complex stmt") + | Instr il -> + pCount := !pCount + List.length il + | _ -> incr pCount); + if !pCount > 5 then raise (Failure ("cannot duplicate: too many instr")); +*) + (* We can just copy it because there is nothing to share here. + * Except maybe for the ref cell in Goto but it is Ok to share + * that, I think *) + { s with sid = s.sid}) c.stmts; + postins = c.postins; (* There is no shared stuff in instructions *) + cases = [] + } +(* + let duplicateChunk (c: chunk) = + if isEmpty c then c else raise (Failure ("cannot duplicate: isNotEmpty")) +*) + (* We can drop a chunk if it does not have labels inside *) + let canDrop (c: chunk) = + List.for_all canDropStatement c.stmts + +(* + let loopChunk (body: chunk) : chunk = + (* Make the statement *) + let loop = mkStmt (Loop (c2block body, !currentLoc, None, None)) in + { stmts = [ loop (* ; n *) ]; + postins = []; + cases = body.cases; + } +*) + + let whileChunk (e: exp) (body: chunk) : chunk = + let loop = mkStmt (While (e, c2block body, !currentLoc)) in + + { stmts = [ loop ]; + postins = []; + cases = body.cases; + } + + let doWhileChunk (e: exp) (body: chunk) : chunk = + let loop = mkStmt (DoWhile (e, c2block body, !currentLoc)) in + + { stmts = [ loop ]; + postins = []; + cases = body.cases; + } + + let forChunk (bInit: chunk) (e: exp) (bIter: chunk) + (body: chunk) : chunk = + let loop = mkStmt (For (c2block bInit, e, c2block bIter, + c2block body, !currentLoc)) in + + { stmts = [ loop ]; + postins = []; + cases = body.cases; + } + + let breakChunk (l: location) : chunk = + { stmts = [ mkStmt (Break l) ]; + postins = []; + cases = []; + } + + let continueChunk (l: location) : chunk = + { stmts = [ mkStmt (Continue l) ]; + postins = []; + cases = [] + } + + (* Keep track of the gotos *) + let backPatchGotos : (string, stmt ref list ref) H.t = H.create 17 + let addGoto (lname: string) (bref: stmt ref) : unit = + let gotos = + try + H.find backPatchGotos lname + with Not_found -> begin + let gotos = ref [] in + H.add backPatchGotos lname gotos; + gotos + end + in + gotos := bref :: !gotos + + (* Keep track of the labels *) + let labelStmt : (string, stmt) H.t = H.create 17 + let initLabels () = + H.clear backPatchGotos; + H.clear labelStmt + + let resolveGotos () = + H.iter + (fun lname gotos -> + try + let dest = H.find labelStmt lname in + List.iter (fun gref -> gref := dest) !gotos + with Not_found -> begin + E.s (error "Label %s not found\n" lname) + end) + backPatchGotos + + (* Get the first statement in a chunk. Might need to change the + * statements in the chunk *) + let getFirstInChunk (c: chunk) : stmt * stmt list = + (* Get the first statement and add the label to it *) + match c.stmts with + s :: _ -> s, c.stmts + | [] -> (* Add a statement *) + let n = mkEmptyStmt () in + n, n :: c.stmts + + let consLabel (l: string) (c: chunk) (loc: location) + (in_original_program_text : bool) : chunk = + (* Get the first statement and add the label to it *) + let labstmt, stmts' = getFirstInChunk c in + (* Add the label *) + labstmt.labels <- Label (l, loc, in_original_program_text) :: + labstmt.labels; + H.add labelStmt l labstmt; + if c.stmts == stmts' then c else {c with stmts = stmts'} + + let s2c (s:stmt) : chunk = + { stmts = [ s ]; + postins = []; + cases = []; + } + + let gotoChunk (ln: string) (l: location) : chunk = + let gref = ref dummyStmt in + addGoto ln gref; + { stmts = [ mkStmt (Goto (gref, l)) ]; + postins = []; + cases = []; + } + + let caseRangeChunk (el: exp list) (l: location) (next: chunk) = + let fst, stmts' = getFirstInChunk next in + let labels = List.map (fun e -> Case (e, l)) el in + let cases = List.map (fun l -> (l, fst)) labels in + fst.labels <- labels @ fst.labels; + { next with stmts = stmts'; cases = cases @ next.cases} + + let defaultChunk (l: location) (next: chunk) = + let fst, stmts' = getFirstInChunk next in + let lb = Default l in + fst.labels <- lb :: fst.labels; + { next with stmts = stmts'; cases = (lb, fst) :: next.cases} + + + let switchChunk (e: exp) (body: chunk) (l: location) = + (* Make the statement *) + let switch = mkStmt (Switch (e, c2block body, + List.map (fun (_, s) -> s) body.cases, + l)) in + { stmts = [ switch (* ; n *) ]; + postins = []; + cases = []; + } + + let mkFunctionBody (c: chunk) : block = + resolveGotos (); initLabels (); + if c.cases <> [] then + E.s (error "Switch cases not inside a switch statement\n"); + c2block c + + end + +open BlockChunk + + +(************ Labels ***********) +(* +(* Since we turn dowhile and for loops into while we need to take care in + * processing the continue statement. For each loop that we enter we place a + * marker in a list saying what kinds of loop it is. When we see a continue + * for a Non-while loop we must generate a label for the continue *) +type loopstate = + While + | NotWhile of string ref + +let continues : loopstate list ref = ref [] + +let startLoop iswhile = + continues := (if iswhile then While else NotWhile (ref "")) :: !continues +*) + +(* We need to take care while processing the continue statement... + * For each loop that we enter we place a marker in a list saying what + * chunk of code we must duplicate before each continue statement + * in order to preserve the semantics. *) +type loopMarker = + | DuplicateBeforeContinue of chunk + | ContinueUnchanged + +let continues : loopMarker list ref = ref [] + +let startLoop lstate = + continues := lstate :: !continues + +let continueDuplicateChunk (l: location) : chunk = + match !continues with + | [] -> E.s (error "continue not in a loop") + | DuplicateBeforeContinue c :: _ -> c @@ continueChunk l + | ContinueUnchanged :: _ -> continueChunk l + +(* Sometimes we need to create new label names *) +let newLabelName (base: string) = fst (newAlphaName false "label" base) + +(* +let continueOrLabelChunk (l: location) : chunk = + match !continues with + [] -> E.s (error "continue not in a loop") + | While :: _ -> continueChunk l + | NotWhile lr :: _ -> + if !lr = "" then begin + lr := newLabelName "__Cont" + end; + gotoChunk !lr l + +let consLabContinue (c: chunk) = + match !continues with + [] -> E.s (error "labContinue not in a loop") + | While :: rest -> c + | NotWhile lr :: rest -> if !lr = "" then c else consLabel !lr c !currentLoc false +*) + +let exitLoop () = + match !continues with + [] -> E.s (error "exit Loop not in a loop") + | _ :: rest -> continues := rest + + +(* In GCC we can have locally declared labels. *) +let genNewLocalLabel (l: string) = + (* Call the newLabelName to register the label name in the alpha conversion + * table. *) + let l' = newLabelName l in + (* Add it to the environment *) + addLocalToEnv (kindPlusName "label" l) (EnvLabel l'); + l' + +let lookupLabel (l: string) = + try + match H.find env (kindPlusName "label" l) with + EnvLabel l', _ -> l' + | _ -> raise Not_found + with Not_found -> + l + + +(** ALLOCA ***) +let allocaFun () = + let name = + if !msvcMode then "alloca" + (* Use __builtin_alloca where possible, because this can be used + even when gcc is invoked with -fno-builtin *) + else "__builtin_alloca" + in + let fdec = emptyFunction name in + fdec.svar.vtype <- + TFun(voidPtrType, Some [ ("len", !typeOfSizeOf, []) ], false, []); + fdec.svar + +(* Maps local variables that are variable sized arrays to the expression that + * denotes their length *) +let varSizeArrays : exp IH.t = IH.create 17 + +(**** EXP actions ***) +type expAction = + ADrop (* Drop the result. Only the + * side-effect is interesting *) + | ASet of lval * typ (* Put the result in a given lval, + * provided it matches the type. The + * type is the type of the lval. *) + | AExp of typ option (* Return the exp as usual. + * Optionally we can specify an + * expected type. This is useful for + * constants. The expected type is + * informational only, we do not + * guarantee that the converted + * expression has that type.You must + * use a doCast afterwards to make + * sure. *) + | AExpLeaveArrayFun (* Do it like an expression, but do + * not convert arrays of functions + * into pointers *) + + +(*** Result of compiling conditional expressions *) +type condExpRes = + CEExp of chunk * exp (* Do a chunk and then an expression *) + | CEAnd of condExpRes * condExpRes + | CEOr of condExpRes * condExpRes + | CENot of condExpRes + +(******** CASTS *********) +let integralPromotion (t : typ) : typ = (* c.f. ISO 6.3.1.1 *) + match unrollType t with + (* We assume that an IInt can hold even an IUShort *) + TInt ((IShort|IUShort|IChar|ISChar|IUChar), a) -> TInt(IInt, a) + | TInt _ -> t + | TEnum (_, a) -> TInt(IInt, a) + | t -> E.s (error "integralPromotion: not expecting %a" d_type t) + + +let arithmeticConversion (* c.f. ISO 6.3.1.8 *) + (t1: typ) + (t2: typ) : typ = + let checkToInt _ = () in (* dummies for now *) + let checkToFloat _ = () in + match unrollType t1, unrollType t2 with + TFloat(FLongDouble, _), _ -> checkToFloat t2; t1 + | _, TFloat(FLongDouble, _) -> checkToFloat t1; t2 + | TFloat(FDouble, _), _ -> checkToFloat t2; t1 + | _, TFloat (FDouble, _) -> checkToFloat t1; t2 + | TFloat(FFloat, _), _ -> checkToFloat t2; t1 + | _, TFloat (FFloat, _) -> checkToFloat t1; t2 + | _, _ -> begin + let t1' = integralPromotion t1 in + let t2' = integralPromotion t2 in + match unrollType t1', unrollType t2' with + TInt(IULongLong, _), _ -> checkToInt t2'; t1' + | _, TInt(IULongLong, _) -> checkToInt t1'; t2' + + (* We assume a long long is always larger than a long *) + | TInt(ILongLong, _), _ -> checkToInt t2'; t1' + | _, TInt(ILongLong, _) -> checkToInt t1'; t2' + + | TInt(IULong, _), _ -> checkToInt t2'; t1' + | _, TInt(IULong, _) -> checkToInt t1'; t2' + + + | TInt(ILong,_), TInt(IUInt,_) + when bitsSizeOf t1' <= bitsSizeOf t2' -> TInt(IULong,[]) + | TInt(IUInt,_), TInt(ILong,_) + when bitsSizeOf t2' <= bitsSizeOf t1' -> TInt(IULong,[]) + + | TInt(ILong, _), _ -> checkToInt t2'; t1' + | _, TInt(ILong, _) -> checkToInt t1'; t2' + + | TInt(IUInt, _), _ -> checkToInt t2'; t1' + | _, TInt(IUInt, _) -> checkToInt t1'; t2' + + | TInt(IInt, _), TInt (IInt, _) -> t1' + + | _, _ -> E.s (error "arithmeticConversion") + end + + +(* Specify whether the cast is from the source code *) +let rec castTo ?(fromsource=false) + (ot : typ) (nt : typ) (e : exp) : (typ * exp ) = +(* + ignore (E.log "%t: castTo:%s %a->%a\n" + d_thisloc + (if fromsource then "(source)" else "") + d_type ot d_type nt); +*) + if not fromsource && Util.equals (typeSig ot) (typeSig nt) then + (* Do not put the cast if it is not necessary, unless it is from the + * source. *) + (ot, e) + else begin + let result = (nt, + if !insertImplicitCasts || fromsource then mkCastT e ot nt else e) in +(* + ignore (E.log "castTo: ot=%a nt=%a\n result is %a\n" + d_type ot d_type nt + d_plainexp (snd result)); +*) + (* Now see if we can have a cast here *) + match ot, nt with + TNamed(r, _), _ -> castTo ~fromsource:fromsource r.ttype nt e + | _, TNamed(r, _) -> castTo ~fromsource:fromsource ot r.ttype e + | TInt(ikindo,_), TInt(ikindn,_) -> + (* We used to ignore attributes on integer-integer casts. Not anymore *) + (* if ikindo = ikindn then (nt, e) else *) + result + + | TPtr (told, _), TPtr(tnew, _) -> result + + | TInt _, TPtr _ -> result + + | TPtr _, TInt _ -> result + + | TArray _, TPtr _ -> result + + | TArray(t1,_,_), TArray(t2,None,_) when Util.equals (typeSig t1) (typeSig t2) -> (nt, e) + + | TPtr _, TArray(_,_,_) -> (nt, e) + + | TEnum _, TInt _ -> result + | TFloat _, (TInt _|TEnum _) -> result + | (TInt _|TEnum _), TFloat _ -> result + | TFloat _, TFloat _ -> result + | TInt _, TEnum _ -> result + | TEnum _, TEnum _ -> result + + | TEnum _, TPtr _ -> result + | TBuiltin_va_list _, (TInt _ | TPtr _) -> + result + + | (TInt _ | TPtr _), TBuiltin_va_list _ -> + ignore (warnOpt "Casting %a to __builtin_va_list" d_type ot); + result + + | TPtr _, TEnum _ -> + ignore (warnOpt "Casting a pointer into an enumeration type"); + result + + (* The expression is evaluated for its side-effects *) + | (TInt _ | TEnum _ | TPtr _ ), TVoid _ -> + (ot, e) + + (* Even casts between structs are allowed when we are only + * modifying some attributes *) + | TComp (comp1, a1), TComp (comp2, a2) when comp1.ckey = comp2.ckey -> + (nt, e) + + (** If we try to pass a transparent union value to a function + * expecting a transparent union argument, the argument type would + * have been changed to the type of the first argument, and we'll + * see a cast from a union to the type of the first argument. Turn + * that into a field access *) + | TComp(tunion, a1), nt -> begin + match isTransparentUnion ot with + None -> E.s (error "castTo %a -> %a@!" d_type ot d_type nt) + | Some fstfield -> begin + (* We do it now only if the expression is an lval *) + let e' = + match e with + Lval lv -> + Lval (addOffsetLval (Field(fstfield, NoOffset)) lv) + | _ -> E.s (unimp "castTo: transparent union expression is not an lval: %a\n" d_exp e) + in + (* Continue casting *) + castTo ~fromsource:fromsource fstfield.ftype nt e' + end + end + | _ -> E.s (error "cabs2cil: castTo %a -> %a@!" d_type ot d_type nt) + end + + +(* A cast that is used for conditional expressions. Pointers are Ok *) +let checkBool (ot : typ) (e : exp) : bool = + match unrollType ot with + TInt _ -> true + | TPtr _ -> true + | TEnum _ -> true + | TFloat _ -> true + | _ -> E.s (error "castToBool %a" d_type ot) + +(* Given an expression that is being coerced to bool, + is it a nonzero constant? *) +let rec isConstTrue (e:exp): bool = + match e with + | Const(CInt64 (n,_,_)) -> n <> Int64.zero + | Const(CChr c) -> 0 <> Char.code c + | Const(CStr _ | CWStr _) -> true + | Const(CReal(f, _, _)) -> f <> 0.0; + | CastE(_, e) -> isConstTrue e + | _ -> false + +(* Given an expression that is being coerced to bool, is it zero? + This is a more general version of Cil.isZero, which only handles integers. + On constant expressions, either isConstTrue or isConstFalse will hold. *) +let rec isConstFalse (e:exp): bool = + match e with + | Const(CInt64 (n,_,_)) -> n = Int64.zero + | Const(CChr c) -> 0 = Char.code c + | Const(CReal(f, _, _)) -> f = 0.0; + | CastE(_, e) -> isConstFalse e + | _ -> false + + + +(* We have our own version of addAttributes that does not allow duplicates *) +let cabsAddAttributes al0 (al: attributes) : attributes = + if al0 == [] then al else + List.fold_left + (fun acc (Attr(an, _) as a) -> + (* See if the attribute is already in there *) + match filterAttributes an acc with + [] -> addAttribute a acc (* Nothing with that name *) + | a' :: _ -> + if Util.equals a a' then + acc (* Already in *) + else begin + ignore (warnOpt + "Duplicate attribute %a along with %a" + d_attr a d_attr a'); + (* let acc' = dropAttribute an acc in *) + (** Keep both attributes *) + addAttribute a acc + end) + al + al0 + +let cabsTypeAddAttributes a0 t = + begin + match a0 with + | [] -> + (* no attributes, keep same type *) + t + | _ -> + (* anything else: add a0 to existing attributes *) + let add (a: attributes) = cabsAddAttributes a0 a in + match t with + TVoid a -> TVoid (add a) + | TInt (ik, a) -> + (* Here we have to watch for the mode attribute *) +(* sm: This stuff is to handle a GCC extension where you can request integers*) +(* of specific widths using the "mode" attribute syntax; for example: *) +(* typedef int int8_t __attribute__ ((__mode__ ( __QI__ ))) ; *) +(* The cryptic "__QI__" defines int8_t to be 8 bits wide, instead of the *) +(* 32 bits you'd guess if you didn't know about "mode". The relevant *) +(* testcase is test/small2/mode_sizes.c, and it was inspired by my *) +(* /usr/include/sys/types.h. *) +(* *) +(* A consequence of this handling is that we throw away the mode *) +(* attribute, which we used to go out of our way to avoid printing anyway.*) + let ik', a0' = + (* Go over the list of new attributes and come back with a + * filtered list and a new integer kind *) + List.fold_left + (fun (ik', a0') a0one -> + match a0one with + Attr("mode", [ACons(mode,[])]) -> begin + (trace "gccwidth" (dprintf "I see mode %s applied to an int type\n" + mode (* #$@!#@ ML! d_type t *) )); + (* the cases below encode the 32-bit assumption.. *) + match (ik', mode) with + | (IInt, "__QI__") -> (IChar, a0') + | (IInt, "__byte__") -> (IChar, a0') + | (IInt, "__HI__") -> (IShort, a0') + | (IInt, "__SI__") -> (IInt, a0') (* same as t *) + | (IInt, "__word__") -> (IInt, a0') + | (IInt, "__pointer__") -> (IInt, a0') + | (IInt, "__DI__") -> (ILongLong, a0') + + | (IUInt, "__QI__") -> (IUChar, a0') + | (IUInt, "__byte__") -> (IUChar, a0') + | (IUInt, "__HI__") -> (IUShort, a0') + | (IUInt, "__SI__") -> (IUInt, a0') + | (IUInt, "__word__") -> (IUInt, a0') + | (IUInt, "__pointer__")-> (IUInt, a0') + | (IUInt, "__DI__") -> (IULongLong, a0') + + | _ -> + (ignore (error "GCC width mode %s applied to unexpected type, or unexpected mode" + mode)); + (ik', a0one :: a0') + + end + | _ -> (ik', a0one :: a0')) + (ik, []) + a0 + in + TInt (ik', cabsAddAttributes a0' a) + + | TFloat (fk, a) -> TFloat (fk, add a) + | TEnum (enum, a) -> TEnum (enum, add a) + | TPtr (t, a) -> TPtr (t, add a) + | TArray (t, l, a) -> TArray (t, l, add a) + | TFun (t, args, isva, a) -> TFun(t, args, isva, add a) + | TComp (comp, a) -> TComp (comp, add a) + | TNamed (t, a) -> TNamed (t, add a) + | TBuiltin_va_list a -> TBuiltin_va_list (add a) + end + + +(* Do types *) + (* Combine the types. Raises the Failure exception with an error message. + * isdef says whether the new type is for a definition *) +type combineWhat = + CombineFundef (* The new definition is for a function definition. The old + * is for a prototype *) + | CombineFunarg (* Comparing a function argument type with an old prototype + * arg *) + | CombineFunret (* Comparing the return of a function with that from an old + * prototype *) + | CombineOther + +(* We sometimes want to succeed in combining two structure types that are + * identical except for the names of the structs. We keep a list of types + * that are known to be equal *) +let isomorphicStructs : (string * string, bool) H.t = H.create 15 + +let rec combineTypes (what: combineWhat) (oldt: typ) (t: typ) : typ = + match oldt, t with + | TVoid olda, TVoid a -> TVoid (cabsAddAttributes olda a) + | TInt (oldik, olda), TInt (ik, a) -> + let combineIK oldk k = + if oldk = k then oldk else + (* GCC allows a function definition to have a more precise integer + * type than a prototype that says "int" *) + if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32 + && (what = CombineFunarg || what = CombineFunret) then + k + else + raise (Failure "different integer types") + in + TInt (combineIK oldik ik, cabsAddAttributes olda a) + | TFloat (oldfk, olda), TFloat (fk, a) -> + let combineFK oldk k = + if oldk = k then oldk else + (* GCC allows a function definition to have a more precise integer + * type than a prototype that says "double" *) + if not !msvcMode && oldk = FDouble && k = FFloat + && (what = CombineFunarg || what = CombineFunret) then + k + else + raise (Failure "different floating point types") + in + TFloat (combineFK oldfk fk, cabsAddAttributes olda a) + | TEnum (_, olda), TEnum (ei, a) -> + TEnum (ei, cabsAddAttributes olda a) + + (* Strange one. But seems to be handled by GCC *) + | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei, + cabsAddAttributes olda a) + (* Strange one. But seems to be handled by GCC *) + | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, cabsAddAttributes olda a) + + + | TComp (oldci, olda) , TComp (ci, a) -> + if oldci.cstruct <> ci.cstruct then + raise (Failure "different struct/union types"); + let comb_a = cabsAddAttributes olda a in + if oldci.cname = ci.cname then + TComp (oldci, comb_a) + else + (* Now maybe they are actually the same *) + if H.mem isomorphicStructs (oldci.cname, ci.cname) then + (* We know they are the same *) + TComp (oldci, comb_a) + else begin + (* If one has 0 fields (undefined) while the other has some fields + * we accept it *) + let oldci_nrfields = List.length oldci.cfields in + let ci_nrfields = List.length ci.cfields in + if oldci_nrfields = 0 then + TComp (ci, comb_a) + else if ci_nrfields = 0 then + TComp (oldci, comb_a) + else begin + (* Make sure that at least they have the same number of fields *) + if oldci_nrfields <> ci_nrfields then begin +(* + ignore (E.log "different number of fields: %s had %d and %s had %d\n" + oldci.cname oldci_nrfields + ci.cname ci_nrfields); +*) + raise (Failure "different structs(number of fields)"); + end; + (* Assume they are the same *) + H.add isomorphicStructs (oldci.cname, ci.cname) true; + H.add isomorphicStructs (ci.cname, oldci.cname) true; + (* Check that the fields are isomorphic and watch for Failure *) + (try + List.iter2 (fun oldf f -> + if oldf.fbitfield <> f.fbitfield then + raise (Failure "different structs(bitfield info)"); + if oldf.fattr <> f.fattr then + raise (Failure "different structs(field attributes)"); + (* Make sure the types are compatible *) + ignore (combineTypes CombineOther oldf.ftype f.ftype); + ) oldci.cfields ci.cfields + with Failure _ as e -> begin + (* Our assumption was wrong. Forget the isomorphism *) + ignore (E.log "\tFailed in our assumption that %s and %s are isomorphic\n" + oldci.cname ci.cname); + H.remove isomorphicStructs (oldci.cname, ci.cname); + H.remove isomorphicStructs (ci.cname, oldci.cname); + raise e + end); + (* We get here if we succeeded *) + TComp (oldci, comb_a) + end + end + + | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) -> + let newbt = combineTypes CombineOther oldbt bt in + let newsz = + match oldsz, sz with + None, Some _ -> sz + | Some _, None -> oldsz + | None, None -> sz + | Some oldsz', Some sz' -> + (* They are not structurally equal. But perhaps they are equal if + * we evaluate them. Check first machine independent comparison *) + let checkEqualSize (machdep: bool) = + Util.equals (constFold machdep oldsz') + (constFold machdep sz') + in + if checkEqualSize false then + oldsz + else if checkEqualSize true then begin + ignore (warn "Array type comparison succeeds only based on machine-dependent constant evaluation: %a and %a\n" + d_exp oldsz' d_exp sz'); + oldsz + end else + raise (Failure "different array lengths") + + in + TArray (newbt, newsz, cabsAddAttributes olda a) + + | TPtr (oldbt, olda), TPtr (bt, a) -> + TPtr (combineTypes CombineOther oldbt bt, cabsAddAttributes olda a) + + | TFun (_, _, _, [Attr("missingproto",_)]), TFun _ -> t + + | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) -> + let newrt = combineTypes + (if what = CombineFundef then CombineFunret else CombineOther) + oldrt rt + in + if oldva != va then + raise (Failure "diferent vararg specifiers"); + (* If one does not have arguments, believe the one with the + * arguments *) + let newargs = + if oldargs = None then args else + if args = None then oldargs else + let oldargslist = argsToList oldargs in + let argslist = argsToList args in + if List.length oldargslist <> List.length argslist then + raise (Failure "different number of arguments") + else begin + (* Go over the arguments and update the old ones with the + * adjusted types *) + Some + (List.map2 + (fun (on, ot, oa) (an, at, aa) -> + (* Update the names. Always prefer the new name. This is + * very important if the prototype uses different names than + * the function definition. *) + let n = if an <> "" then an else on in + let t = + combineTypes + (if what = CombineFundef then + CombineFunarg else CombineOther) + ot at + in + let a = addAttributes oa aa in + (n, t, a)) + oldargslist argslist) + end + in + TFun (newrt, newargs, oldva, cabsAddAttributes olda a) + + | TNamed (oldt, olda), TNamed (t, a) when oldt.tname = t.tname -> + TNamed (oldt, cabsAddAttributes olda a) + + | TBuiltin_va_list olda, TBuiltin_va_list a -> + TBuiltin_va_list (cabsAddAttributes olda a) + + (* Unroll first the new type *) + | _, TNamed (t, a) -> + let res = combineTypes what oldt t.ttype in + cabsTypeAddAttributes a res + + (* And unroll the old type as well if necessary *) + | TNamed (oldt, a), _ -> + let res = combineTypes what oldt.ttype t in + cabsTypeAddAttributes a res + + | _ -> raise (Failure "different type constructors") + + +(* Create and cache varinfo's for globals. Starts with a varinfo but if the + * global has been declared already it might come back with another varinfo. + * Returns the varinfo to use (might be the old one), and an indication + * whether the variable exists already in the environment *) +let makeGlobalVarinfo (isadef: bool) (vi: varinfo) : varinfo * bool = + try (* See if already defined, in the global environment. We could also + * look it up in the whole environment but in that case we might see a + * local. This can happen when we declare an extern variable with + * global scope but we are in a local scope. *) + let oldvi, oldloc = lookupGlobalVar vi.vname in + (* It was already defined. We must reuse the varinfo. But clean up the + * storage. *) + let newstorage = (** See 6.2.2 *) + match oldvi.vstorage, vi.vstorage with + (* Extern and something else is that thing *) + | Extern, other + | other, Extern -> other + + | NoStorage, other + | other, NoStorage -> other + + + | _ -> + if vi.vstorage != oldvi.vstorage then + ignore (warn + "Inconsistent storage specification for %s. Previous declaration: %a" + vi.vname d_loc oldloc); + vi.vstorage + in + oldvi.vinline <- oldvi.vinline || vi.vinline; + oldvi.vstorage <- newstorage; + (* Union the attributes *) + oldvi.vattr <- cabsAddAttributes oldvi.vattr vi.vattr; + begin + try + oldvi.vtype <- + combineTypes + (if isadef then CombineFundef else CombineOther) + oldvi.vtype vi.vtype; + with Failure reason -> + ignore (E.log "old type = %a\n" d_plaintype oldvi.vtype); + ignore (E.log "new type = %a\n" d_plaintype vi.vtype); + E.s (error "Declaration of %s does not match previous declaration from %a (%s)." + vi.vname d_loc oldloc reason) + end; + + (* Found an old one. Keep the location always from the definition *) + if isadef then begin + oldvi.vdecl <- vi.vdecl; + end; + oldvi, true + + with Not_found -> begin (* A new one. *) + (* Announce the name to the alpha conversion table. This will not + * actually change the name of the vi. See the definition of + * alphaConvertVarAndAddToEnv *) + alphaConvertVarAndAddToEnv true vi, false + end + +let conditionalConversion (t2: typ) (t3: typ) : typ = + let tresult = (* ISO 6.5.15 *) + match unrollType t2, unrollType t3 with + (TInt _ | TEnum _ | TFloat _), + (TInt _ | TEnum _ | TFloat _) -> + arithmeticConversion t2 t3 + | TComp (comp2,_), TComp (comp3,_) + when comp2.ckey = comp3.ckey -> t2 + | TPtr(_, _), TPtr(TVoid _, _) -> t2 + | TPtr(TVoid _, _), TPtr(_, _) -> t3 + | TPtr _, TPtr _ when Util.equals (typeSig t2) (typeSig t3) -> t2 + | TPtr _, TInt _ -> t2 (* most likely comparison with 0 *) + | TInt _, TPtr _ -> t3 (* most likely comparison with 0 *) + + (* When we compare two pointers of diffent type, we combine them + * using the same algorithm when combining multiple declarations of + * a global *) + | (TPtr _) as t2', (TPtr _ as t3') -> begin + try combineTypes CombineOther t2' t3' + with Failure msg -> begin + ignore (warn "A.QUESTION: %a does not match %a (%s)" + d_type (unrollType t2) d_type (unrollType t3) msg); + t2 (* Just pick one *) + end + end + | _, _ -> E.s (error "A.QUESTION for invalid combination of types") + in + tresult + +(* Some utilitites for doing initializers *) + +let debugInit = false + +type preInit = + | NoInitPre + | SinglePre of exp + | CompoundPre of int ref (* the maximum used index *) + * preInit array ref (* an array with initializers *) + +(* Instructions on how to handle designators *) +type handleDesignators = + | Handle (* Handle them yourself *) + | DoNotHandle (* Do not handle them your self *) + | HandleAsNext (* First behave as if you have a NEXT_INIT. Useful for going + * into nested designators *) + | HandleFirst (* Handle only the first designator *) + +(* Set an initializer *) +let rec setOneInit (this: preInit) + (o: offset) (e: exp) : preInit = + match o with + NoOffset -> SinglePre e + | _ -> + let idx, (* Index in the current comp *) + restoff (* Rest offset *) = + match o with + | Index(Const(CInt64(i,_,_)), off) -> Int64.to_int i, off + | Field (f, off) -> + (* Find the index of the field *) + let rec loop (idx: int) = function + [] -> E.s (bug "Cannot find field %s" f.fname) + | f' :: _ when f'.fname = f.fname -> idx + | _ :: restf -> loop (idx + 1) restf + in + loop 0 f.fcomp.cfields, off + | _ -> E.s (bug "setOneInit: non-constant index") + in + let pMaxIdx, pArray = + match this with + NoInitPre -> (* No initializer so far here *) + ref idx, ref (Array.create (max 32 (idx + 1)) NoInitPre) + + | CompoundPre (pMaxIdx, pArray) -> + if !pMaxIdx < idx then begin + pMaxIdx := idx; + (* Maybe we also need to grow the array *) + let l = Array.length !pArray in + if l <= idx then begin + let growBy = max (max 32 (idx + 1 - l)) (l / 2) in + let newarray = Array.make (growBy + idx) NoInitPre in + Array.blit !pArray 0 newarray 0 l; + pArray := newarray + end + end; + pMaxIdx, pArray + | SinglePre e -> + E.s (unimp "Index %d is already initialized" idx) + in + assert (idx >= 0 && idx < Array.length !pArray); + let this' = setOneInit !pArray.(idx) restoff e in + !pArray.(idx) <- this'; + CompoundPre (pMaxIdx, pArray) + + +(* collect a CIL initializer, given the original syntactic initializer + * 'preInit'; this returns a type too, since initialization of an array + * with unspecified size actually changes the array's type + * (ANSI C, 6.7.8, para 22) *) +let rec collectInitializer + (this: preInit) + (thistype: typ) : (init * typ) = + if this = NoInitPre then (makeZeroInit thistype), thistype + else + match unrollType thistype, this with + | _ , SinglePre e -> SingleInit e, thistype + | TArray (bt, leno, at), CompoundPre (pMaxIdx, pArray) -> + let (len: int), newtype = + (* normal case: use array's declared length, newtype=thistype *) + match leno with + Some len -> begin + match constFold true len with + Const(CInt64(ni, _, _)) when ni >= 0L -> + (Int64.to_int ni), TArray(bt,leno,at) + + | _ -> E.s (error "Array length is not a constant expression %a" + d_exp len) + end + | _ -> + (* unsized array case, length comes from initializers *) + (!pMaxIdx + 1, + TArray (bt, Some (integer (!pMaxIdx + 1)), at)) + in + if !pMaxIdx >= len then + E.s (E.bug "collectInitializer: too many initializers(%d >= %d)\n" + !pMaxIdx len); + (* len could be extremely big. So omit the last initializers, if they + * are many (more than 16) *) +(* + ignore (E.log "collectInitializer: len = %d, pMaxIdx= %d\n" + len !pMaxIdx); *) + let endAt = + if len - 1 > !pMaxIdx + 16 then + !pMaxIdx + else + len - 1 + in + (* Make one zero initializer to be used next *) + let oneZeroInit = makeZeroInit bt in + let rec collect (acc: (offset * init) list) (idx: int) = + if idx = -1 then acc + else + let thisi = + if idx > !pMaxIdx then oneZeroInit + else (fst (collectInitializer !pArray.(idx) bt)) + in + collect ((Index(integer idx, NoOffset), thisi) :: acc) (idx - 1) + in + + CompoundInit (newtype, collect [] endAt), newtype + + | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when comp.cstruct -> + let rec collect (idx: int) = function + [] -> [] + | f :: restf -> + if f.fname = missingFieldName then + collect (idx + 1) restf + else + let thisi = + if idx > !pMaxIdx then + makeZeroInit f.ftype + else + collectFieldInitializer !pArray.(idx) f + in + (Field(f, NoOffset), thisi) :: collect (idx + 1) restf + in + CompoundInit (thistype, collect 0 comp.cfields), thistype + + | TComp (comp, _), CompoundPre (pMaxIdx, pArray) when not comp.cstruct -> + (* Find the field to initialize *) + let rec findField (idx: int) = function + [] -> E.s (bug "collectInitializer: union") + | _ :: rest when idx < !pMaxIdx && !pArray.(idx) = NoInitPre -> + findField (idx + 1) rest + | f :: _ when idx = !pMaxIdx -> + Field(f, NoOffset), + collectFieldInitializer !pArray.(idx) f + | _ -> E.s (error "Can initialize only one field for union") + in + if !msvcMode && !pMaxIdx != 0 then + ignore (warn "On MSVC we can initialize only the first field of a union"); + CompoundInit (thistype, [ findField 0 comp.cfields ]), thistype + + | _ -> E.s (unimp "collectInitializer") + +and collectFieldInitializer + (this: preInit) + (f: fieldinfo) : init = + (* collect, and rewrite type *) + let init,newtype = (collectInitializer this f.ftype) in + f.ftype <- newtype; + init + + +type stackElem = + InArray of offset * typ * int * int ref (* offset of parent, base type, + * length, current index. If the + * array length is unspecified we + * use Int.max_int *) + | InComp of offset * compinfo * fieldinfo list (* offset of parent, + base comp, current fields *) + + +(* A subobject is given by its address. The address is read from the end of + * the list (the bottom of the stack), starting with the current object *) +type subobj = { mutable stack: stackElem list; (* With each stack element we + * store the offset of its + * PARENT *) + mutable eof: bool; (* The stack is empty and we reached the + * end *) + mutable soTyp: typ; (* The type of the subobject. Set using + * normalSubobj after setting stack. *) + mutable soOff: offset; (* The offset of the subobject. Set + * using normalSubobj after setting + * stack. *) + curTyp: typ; (* Type of current object. See ISO for + * the definition of the current object *) + curOff: offset; (* The offset of the current obj *) + host: varinfo; (* The host that we are initializing. + * For error messages *) + } + + +(* Make a subobject iterator *) +let rec makeSubobj + (host: varinfo) + (curTyp: typ) + (curOff: offset) = + let so = + { host = host; curTyp = curTyp; curOff = curOff; + stack = []; eof = false; + (* The next are fixed by normalSubobj *) + soTyp = voidType; soOff = NoOffset } in + normalSubobj so; + so + + (* Normalize a stack so the we always point to a valid subobject. Do not + * descend into type *) +and normalSubobj (so: subobj) : unit = + match so.stack with + [] -> so.soOff <- so.curOff; so.soTyp <- so.curTyp + (* The array is over *) + | InArray (parOff, bt, leno, current) :: rest -> + if leno = !current then begin (* The array is over *) + if debugInit then ignore (E.log "Past the end of array\n"); + so.stack <- rest; + advanceSubobj so + end else begin + so.soTyp <- bt; + so.soOff <- addOffset (Index(integer !current, NoOffset)) parOff + end + + (* The fields are over *) + | InComp (parOff, comp, nextflds) :: rest -> + if nextflds == [] then begin (* No more fields here *) + if debugInit then ignore (E.log "Past the end of structure\n"); + so.stack <- rest; + advanceSubobj so + end else begin + let fst = List.hd nextflds in + so.soTyp <- fst.ftype; + so.soOff <- addOffset (Field(fst, NoOffset)) parOff + end + + (* Advance to the next subobject. Always apply to a normalized object *) +and advanceSubobj (so: subobj) : unit = + if so.eof then E.s (bug "advanceSubobj past end"); + match so.stack with + | [] -> if debugInit then ignore (E.log "Setting eof to true\n"); + so.eof <- true + | InArray (parOff, bt, leno, current) :: rest -> + if debugInit then ignore (E.log " Advancing to [%d]\n" (!current + 1)); + (* so.stack <- InArray (parOff, bt, leno, current + 1) :: rest; *) + incr current; + normalSubobj so + + (* The fields are over *) + | InComp (parOff, comp, nextflds) :: rest -> + if debugInit then + ignore (E.log "Advancing past .%s\n" (List.hd nextflds).fname); + let flds' = try List.tl nextflds with _ -> E.s (bug "advanceSubobj") in + so.stack <- InComp(parOff, comp, flds') :: rest; + normalSubobj so + + + +(* Find the fields to initialize in a composite. *) +let fieldsToInit + (comp: compinfo) + (designator: string option) + : fieldinfo list = + (* Never look at anonymous fields *) + let flds1 = + List.filter (fun f -> f.fname <> missingFieldName) comp.cfields in + let flds2 = + match designator with + None -> flds1 + | Some fn -> + let rec loop = function + [] -> E.s (error "Cannot find designated field %s" fn) + | (f :: _) as nextflds when f.fname = fn -> nextflds + | _ :: rest -> loop rest + in + loop flds1 + in + (* If it is a union we only initialize one field *) + match flds2 with + [] -> [] + | (f :: rest) as toinit -> + if comp.cstruct then toinit else [f] + + +let integerArrayLength (leno: exp option) : int = + match leno with + None -> max_int + | Some len -> begin + try lenOfArray leno + with LenOfArray -> + E.s (error "Initializing non-constant-length array\n length=%a\n" + d_exp len) + end + +(* sm: I'm sure something like this already exists, but ... *) +let isNone (o : 'a option) : bool = + match o with + | None -> true + | Some _ -> false + + +let annonCompFieldNameId = ref 0 +let annonCompFieldName = "__annonCompField" + + + +(* Utility ***) +let rec replaceLastInList + (lst: A.expression list) + (how: A.expression -> A.expression) : A.expression list= + match lst with + [] -> [] + | [e] -> [how e] + | h :: t -> h :: replaceLastInList t how + + + + + +let convBinOp (bop: A.binary_operator) : binop = + match bop with + A.ADD -> PlusA + | A.SUB -> MinusA + | A.MUL -> Mult + | A.DIV -> Div + | A.MOD -> Mod + | A.BAND -> BAnd + | A.BOR -> BOr + | A.XOR -> BXor + | A.SHL -> Shiftlt + | A.SHR -> Shiftrt + | A.EQ -> Eq + | A.NE -> Ne + | A.LT -> Lt + | A.LE -> Le + | A.GT -> Gt + | A.GE -> Ge + | _ -> E.s (error "convBinOp") + +(**** PEEP-HOLE optimizations ***) +let afterConversion (c: chunk) : chunk = + (* Now scan the statements and find Instr blocks *) + + (** We want to collapse sequences of the form "tmp = f(); v = tmp". This + * will help significantly with the handling of calls to malloc, where it + * is important to have the cast at the same place as the call *) + let collapseCallCast = function + Call(Some(Var vi, NoOffset), f, args, l), + Set(destlv, CastE (newt, Lval(Var vi', NoOffset)), _) + when (not vi.vglob && + String.length vi.vname >= 3 && + (* Watch out for the possibility that we have an implied cast in + * the call *) + (let tcallres = + match unrollType (typeOf f) with + TFun (rt, _, _, _) -> rt + | _ -> E.s (E.bug "Function call to a non-function") + in + Util.equals (typeSig tcallres) (typeSig vi.vtype) && + Util.equals (typeSig newt) (typeSig (typeOfLval destlv))) && + IH.mem callTempVars vi.vid && + vi' == vi) + -> Some [Call(Some destlv, f, args, l)] + | i1,i2 -> None + in + (* First add in the postins *) + let sl = pushPostIns c in + peepHole2 collapseCallCast sl; + { c with stmts = sl; postins = [] } + +(***** Try to suggest a name for the anonymous structures *) +let suggestAnonName (nl: A.name list) = + match nl with + [] -> "" + | (n, _, _, _) :: _ -> n + + +(** Optional constant folding of binary operations *) +let optConstFoldBinOp (machdep: bool) (bop: binop) + (e1: exp) (e2:exp) (t: typ) = + if !lowerConstants then + constFoldBinOp machdep bop e1 e2 t + else + BinOp(bop, e1, e2, t) + +(****** TYPE SPECIFIERS *******) +let rec doSpecList (suggestedAnonName: string) (* This string will be part of + * the names for anonymous + * structures and enums *) + (specs: A.spec_elem list) + (* Returns the base type, the storage, whether it is inline and the + * (unprocessed) attributes *) + : typ * storage * bool * A.attribute list = + (* Do one element and collect the type specifiers *) + let isinline = ref false in (* If inline appears *) + (* The storage is placed here *) + let storage : storage ref = ref NoStorage in + + (* Collect the attributes. Unfortunately, we cannot treat GCC + * __attributes__ and ANSI C const/volatile the same way, since they + * associate with structures differently. Specifically, ANSI + * qualifiers never apply to structures (ISO 6.7.3), whereas GCC + * attributes always do (GCC manual 4.30). Therefore, they are + * collected and processed separately. *) + let attrs : A.attribute list ref = ref [] in (* __attribute__, etc. *) + let cvattrs : A.cvspec list ref = ref [] in (* const/volatile *) + + let doSpecElem (se: A.spec_elem) + (acc: A.typeSpecifier list) + : A.typeSpecifier list = + match se with + A.SpecTypedef -> acc + | A.SpecInline -> isinline := true; acc + | A.SpecStorage st -> + if !storage <> NoStorage then + E.s (error "Multiple storage specifiers"); + let sto' = + match st with + A.NO_STORAGE -> NoStorage + | A.AUTO -> NoStorage + | A.REGISTER -> Register + | A.STATIC -> Static + | A.EXTERN -> Extern + in + storage := sto'; + acc + + | A.SpecCV cv -> cvattrs := cv :: !cvattrs; acc + | A.SpecAttr a -> attrs := a :: !attrs; acc + | A.SpecType ts -> ts :: acc + | A.SpecPattern _ -> E.s (E.bug "SpecPattern in cabs2cil input") + in + (* Now scan the list and collect the type specifiers. Preserve the order *) + let tspecs = List.fold_right doSpecElem specs [] in + + let tspecs' = + (* GCC allows a named type that appears first to be followed by things + * like "short", "signed", "unsigned" or "long". *) + match tspecs with + A.Tnamed n :: (_ :: _ as rest) when not !msvcMode -> + (* If rest contains "short" or "long" then drop the Tnamed *) + if List.exists (function A.Tshort -> true + | A.Tlong -> true | _ -> false) rest then + rest + else + tspecs + + | _ -> tspecs + in + (* Sort the type specifiers *) + let sortedspecs = + let order = function (* Don't change this *) + | A.Tvoid -> 0 + | A.Tsigned -> 1 + | A.Tunsigned -> 2 + | A.Tchar -> 3 + | A.Tshort -> 4 + | A.Tlong -> 5 + | A.Tint -> 6 + | A.Tint64 -> 7 + | A.Tfloat -> 8 + | A.Tdouble -> 9 + | _ -> 10 (* There should be at most one of the others *) + in + List.stable_sort (fun ts1 ts2 -> compare (order ts1) (order ts2)) tspecs' + in + let getTypeAttrs () : A.attribute list = + (* Partitions the attributes in !attrs. + Type attributes are removed from attrs and returned, so that they + can go into the type definition. Name attributes are left in attrs, + so they will be returned by doSpecAttr and used in the variable + declaration. + Testcase: small1/attr9.c *) + let an, af, at = cabsPartitionAttributes ~default:AttrType !attrs in + attrs := an; (* Save the name attributes for later *) + if af <> [] then + E.s (error "Invalid position for function type attributes."); + at + in + + (* And now try to make sense of it. See ISO 6.7.2 *) + let bt = + match sortedspecs with + [A.Tvoid] -> TVoid [] + | [A.Tchar] -> TInt(IChar, []) + | [A.Tsigned; A.Tchar] -> TInt(ISChar, []) + | [A.Tunsigned; A.Tchar] -> TInt(IUChar, []) + + | [A.Tshort] -> TInt(IShort, []) + | [A.Tsigned; A.Tshort] -> TInt(IShort, []) + | [A.Tshort; A.Tint] -> TInt(IShort, []) + | [A.Tsigned; A.Tshort; A.Tint] -> TInt(IShort, []) + + | [A.Tunsigned; A.Tshort] -> TInt(IUShort, []) + | [A.Tunsigned; A.Tshort; A.Tint] -> TInt(IUShort, []) + + | [] -> TInt(IInt, []) + | [A.Tint] -> TInt(IInt, []) + | [A.Tsigned] -> TInt(IInt, []) + | [A.Tsigned; A.Tint] -> TInt(IInt, []) + + | [A.Tunsigned] -> TInt(IUInt, []) + | [A.Tunsigned; A.Tint] -> TInt(IUInt, []) + + | [A.Tlong] -> TInt(ILong, []) + | [A.Tsigned; A.Tlong] -> TInt(ILong, []) + | [A.Tlong; A.Tint] -> TInt(ILong, []) + | [A.Tsigned; A.Tlong; A.Tint] -> TInt(ILong, []) + + | [A.Tunsigned; A.Tlong] -> TInt(IULong, []) + | [A.Tunsigned; A.Tlong; A.Tint] -> TInt(IULong, []) + + | [A.Tlong; A.Tlong] -> TInt(ILongLong, []) + | [A.Tsigned; A.Tlong; A.Tlong] -> TInt(ILongLong, []) + | [A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, []) + | [A.Tsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(ILongLong, []) + + | [A.Tunsigned; A.Tlong; A.Tlong] -> TInt(IULongLong, []) + | [A.Tunsigned; A.Tlong; A.Tlong; A.Tint] -> TInt(IULongLong, []) + + (* int64 is to support MSVC *) + | [A.Tint64] -> TInt(ILongLong, []) + | [A.Tsigned; A.Tint64] -> TInt(ILongLong, []) + + | [A.Tunsigned; A.Tint64] -> TInt(IULongLong, []) + + | [A.Tfloat] -> TFloat(FFloat, []) + | [A.Tdouble] -> TFloat(FDouble, []) + + | [A.Tlong; A.Tdouble] -> TFloat(FLongDouble, []) + + (* Now the other type specifiers *) + | [A.Tnamed n] -> begin + if n = "__builtin_va_list" && + Machdep.gccHas__builtin_va_list then begin + TBuiltin_va_list [] + end else + let t = + match lookupType "type" n with + (TNamed _) as x, _ -> x + | typ -> E.s (error "Named type %s is not mapped correctly\n" n) + in + t + end + + | [A.Tstruct (n, None, _)] -> (* A reference to a struct *) + if n = "" then E.s (error "Missing struct tag on incomplete struct"); + findCompType "struct" n [] + | [A.Tstruct (n, Some nglist, extraAttrs)] -> (* A definition of a struct *) + let n' = + if n <> "" then n else anonStructName "struct" suggestedAnonName in + (* Use the (non-cv, non-name) attributes in !attrs now *) + let a = extraAttrs @ (getTypeAttrs ()) in + makeCompType true n' nglist (doAttributes a) + + | [A.Tunion (n, None, _)] -> (* A reference to a union *) + if n = "" then E.s (error "Missing union tag on incomplete union"); + findCompType "union" n [] + | [A.Tunion (n, Some nglist, extraAttrs)] -> (* A definition of a union *) + let n' = + if n <> "" then n else anonStructName "union" suggestedAnonName in + (* Use the attributes now *) + let a = extraAttrs @ (getTypeAttrs ()) in + makeCompType false n' nglist (doAttributes a) + + | [A.Tenum (n, None, _)] -> (* Just a reference to an enum *) + if n = "" then E.s (error "Missing enum tag on incomplete enum"); + findCompType "enum" n [] + + | [A.Tenum (n, Some eil, extraAttrs)] -> (* A definition of an enum *) + let n' = + if n <> "" then n else anonStructName "enum" suggestedAnonName in + (* make a new name for this enumeration *) + let n'', _ = newAlphaName true "enum" n' in + + (* Create the enuminfo, or use one that was created already for a + * forward reference *) + let enum, _ = createEnumInfo n'' in + let a = extraAttrs @ (getTypeAttrs ()) in + enum.eattr <- doAttributes a; + let res = TEnum (enum, []) in + + (* sm: start a scope for the enum tag values, since they * + * can refer to earlier tags *) + enterScope (); + + (* as each name,value pair is determined, this is called *) + let rec processName kname (i: exp) loc rest = begin + (* add the name to the environment, but with a faked 'typ' field; + * we don't know the full type yet (since that includes all of the + * tag values), but we won't need them in here *) + addLocalToEnv kname (EnvEnum (i, res)); + + (* add this tag to the list so that it ends up in the real + * environment when we're finished *) + let newname, _ = newAlphaName true "" kname in + + (kname, (newname, i, loc)) :: loop (increm i 1) rest + end + + and loop i = function + [] -> [] + | (kname, A.NOTHING, cloc) :: rest -> + (* use the passed-in 'i' as the value, since none specified *) + processName kname i (convLoc cloc) rest + + | (kname, e, cloc) :: rest -> + (* constant-eval 'e' to determine tag value *) + let e' = getIntConstExp e in + let e' = + match isInteger (constFold true e') with + Some i -> if !lowerConstants then kinteger64 IInt i else e' + | _ -> E.s (error "Constant initializer %a not an integer" d_exp e') + in + processName kname e' (convLoc cloc) rest + in + + (* sm: now throw away the environment we built for eval'ing the enum + * tags, so we can add to the new one properly *) + exitScope (); + + let fields = loop zero eil in + (* Now set the right set of items *) + enum.eitems <- List.map (fun (_, x) -> x) fields; + (* Record the enum name in the environment *) + addLocalToEnv (kindPlusName "enum" n'') (EnvTyp res); + (* And define the tag *) + cabsPushGlobal (GEnumTag (enum, !currentLoc)); + res + + + | [A.TtypeofE e] -> + let (c, e', t) = doExp false e AExpLeaveArrayFun in + let t' = + match e' with + StartOf(lv) -> typeOfLval lv + (* If this is a string literal, then we treat it as in sizeof*) + | Const (CStr s) -> begin + match typeOf e' with + TPtr(bt, _) -> (* This is the type of array elements *) + TArray(bt, Some (SizeOfStr s), []) + | _ -> E.s (bug "The typeOf a string is not a pointer type") + end + | _ -> t + in +(* + ignore (E.log "typeof(%a) = %a\n" d_exp e' d_plaintype t'); +*) + t' + + | [A.TtypeofT (specs, dt)] -> + let typ = doOnlyType specs dt in + typ + + | _ -> + E.s (error "Invalid combination of type specifiers") + in + bt,!storage,!isinline,List.rev (!attrs @ (convertCVtoAttr !cvattrs)) + +(* given some cv attributes, convert them into named attributes for + * uniform processing *) +and convertCVtoAttr (src: A.cvspec list) : A.attribute list = + match src with + | [] -> [] + | CV_CONST :: tl -> ("const",[]) :: (convertCVtoAttr tl) + | CV_VOLATILE :: tl -> ("volatile",[]) :: (convertCVtoAttr tl) + | CV_RESTRICT :: tl -> ("restrict",[]) :: (convertCVtoAttr tl) + + +and makeVarInfoCabs + ~(isformal: bool) + ~(isglobal: bool) + (ldecl : location) + (bt, sto, inline, attrs) + (n,ndt,a) + : varinfo = + let vtype, nattr = + doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in + if inline && not (isFunctionType vtype) then + ignore (error "inline for a non-function: %s" n); + let t = + if not isglobal && not isformal then begin + (* Sometimes we call this on the formal argument of a function with no + * arguments. Don't call stripConstLocalType in that case *) +(* ignore (E.log "stripConstLocalType(%a) for %s\n" d_type vtype n); *) + stripConstLocalType vtype + end else + vtype + in + let vi = makeVarinfo isglobal n t in + vi.vstorage <- sto; + vi.vattr <- nattr; + vi.vdecl <- ldecl; + + if false then + ignore (E.log "Created varinfo %s : %a\n" vi.vname d_type vi.vtype); + + vi + +(* Process a local variable declaration and allow variable-sized arrays *) +and makeVarSizeVarInfo (ldecl : location) + spec_res + (n,ndt,a) + : varinfo * chunk * exp * bool = + if not !msvcMode then + match isVariableSizedArray ndt with + None -> + makeVarInfoCabs ~isformal:false + ~isglobal:false + ldecl spec_res (n,ndt,a), empty, zero, false + | Some (ndt', se, len) -> + makeVarInfoCabs ~isformal:false + ~isglobal:false + ldecl spec_res (n,ndt',a), se, len, true + else + makeVarInfoCabs ~isformal:false + ~isglobal:false + ldecl spec_res (n,ndt,a), empty, zero, false + +and doAttr (a: A.attribute) : attribute list = + (* Strip the leading and trailing underscore *) + let stripUnderscore (n: string) : string = + let l = String.length n in + let rec start i = + if i >= l then + E.s (error "Invalid attribute name %s" n); + if String.get n i = '_' then start (i + 1) else i + in + let st = start 0 in + let rec finish i = + (* We know that we will stop at >= st >= 0 *) + if String.get n i = '_' then finish (i - 1) else i + in + let fin = finish (l - 1) in + String.sub n st (fin - st + 1) + in + match a with + | (s, []) -> [Attr (stripUnderscore s, [])] + | (s, el) -> + + let rec attrOfExp (strip: bool) + ?(foldenum=true) + (a: A.expression) : attrparam = + match a with + A.VARIABLE n -> begin + let n' = if strip then stripUnderscore n else n in + (** See if this is an enumeration *) + try + if not foldenum then raise Not_found; + + match H.find env n' with + EnvEnum (tag, _), _ -> begin + match isInteger (constFold true tag) with + Some i64 when !lowerConstants -> AInt (Int64.to_int i64) + | _ -> ACons(n', []) + end + | _ -> ACons (n', []) + with Not_found -> ACons(n', []) + end + | A.CONSTANT (A.CONST_STRING s) -> AStr s + | A.CONSTANT (A.CONST_INT str) -> AInt (int_of_string str) + | A.CALL(A.VARIABLE n, args) -> begin + let n' = if strip then stripUnderscore n else n in + let ae' = List.map ae args in + ACons(n', ae') + end + | A.EXPR_SIZEOF e -> ASizeOfE (ae e) + | A.TYPE_SIZEOF (bt, dt) -> ASizeOf (doOnlyType bt dt) + | A.EXPR_ALIGNOF e -> AAlignOfE (ae e) + | A.TYPE_ALIGNOF (bt, dt) -> AAlignOf (doOnlyType bt dt) + | A.BINARY(A.AND, aa1, aa2) -> + ABinOp(LAnd, ae aa1, ae aa2) + | A.BINARY(A.OR, aa1, aa2) -> + ABinOp(LOr, ae aa1, ae aa2) + | A.BINARY(abop, aa1, aa2) -> + ABinOp (convBinOp abop, ae aa1, ae aa2) + | A.UNARY(A.PLUS, aa) -> ae aa + | A.UNARY(A.MINUS, aa) -> AUnOp (Neg, ae aa) + | A.UNARY(A.BNOT, aa) -> AUnOp(BNot, ae aa) + | A.UNARY(A.NOT, aa) -> AUnOp(LNot, ae aa) + | A.MEMBEROF (e, s) -> ADot (ae e, s) + | _ -> + ignore (E.log "Invalid expression in attribute: "); + withCprint Cprint.print_expression a; + E.s (error "cabs2cil: invalid expression") + + and ae (e: A.expression) = attrOfExp false e in + + (* Sometimes we need to convert attrarg into attr *) + let arg2attr = function + | ACons (s, args) -> Attr (s, args) + | a -> + E.s (error "Invalid form of attribute: %a" + d_attrparam a); + in + if s = "__attribute__" then (* Just a wrapper for many attributes*) + List.map (fun e -> arg2attr (attrOfExp true ~foldenum:false e)) el + else if s = "__blockattribute__" then (* Another wrapper *) + List.map (fun e -> arg2attr (attrOfExp true ~foldenum:false e)) el + else if s = "__declspec" then + List.map (fun e -> arg2attr (attrOfExp false ~foldenum:false e)) el + else + [Attr(stripUnderscore s, List.map (attrOfExp ~foldenum:false false) el)] + +and doAttributes (al: A.attribute list) : attribute list = + List.fold_left (fun acc a -> cabsAddAttributes (doAttr a) acc) [] al + +(* A version of Cil.partitionAttributes that works on CABS attributes. + It would be better to use Cil.partitionAttributes instead to avoid + the extra doAttr conversions here, but that's hard to do in doSpecList.*) +and cabsPartitionAttributes + ~(default:attributeClass) + (attrs: A.attribute list) : + A.attribute list * A.attribute list * A.attribute list = + let rec loop (n,f,t) = function + [] -> n, f, t + | a :: rest -> + let kind = match doAttr a with + [] -> default + | Attr(an, _)::_ -> + (try H.find attributeHash an with Not_found -> default) + in + match kind with + AttrName _ -> loop (a::n, f, t) rest + | AttrFunType _ -> + loop (n, a::f, t) rest + | AttrType -> loop (n, f, a::t) rest + in + loop ([], [], []) attrs + + + +and doType (nameortype: attributeClass) (* This is AttrName if we are doing + * the type for a name, or AttrType + * if we are doing this type in a + * typedef *) + (bt: typ) (* The base type *) + (dt: A.decl_type) + (* Returns the new type and the accumulated name (or type attribute + if nameoftype = AttrType) attributes *) + : typ * attribute list = + + (* Now do the declarator type. But remember that the structure of the + * declarator type is as printed, meaning that it is the reverse of the + * right one *) + let rec doDeclType (bt: typ) (acc: attribute list) = function + A.JUSTBASE -> bt, acc + | A.PARENTYPE (a1, d, a2) -> + let a1' = doAttributes a1 in + let a1n, a1f, a1t = partitionAttributes AttrType a1' in + let a2' = doAttributes a2 in + let a2n, a2f, a2t = partitionAttributes nameortype a2' in +(* + ignore (E.log "doType: %a @[a1n=%a@!a1f=%a@!a1t=%a@!a2n=%a@!a2f=%a@!a2t=%a@]@!" d_loc !currentLoc d_attrlist a1n d_attrlist a1f d_attrlist a1t d_attrlist a2n d_attrlist a2f d_attrlist a2t); +*) + let bt' = cabsTypeAddAttributes a1t bt in +(* + ignore (E.log "bt' = %a\n" d_type bt'); +*) + let bt'', a1fadded = + match unrollType bt with + TFun _ -> cabsTypeAddAttributes a1f bt', true + | _ -> bt', false + in + (* Now recurse *) + let restyp, nattr = doDeclType bt'' acc d in + (* Add some more type attributes *) + let restyp = cabsTypeAddAttributes a2t restyp in + (* See if we can add some more type attributes *) + let restyp' = + match unrollType restyp with + TFun _ -> + if a1fadded then + cabsTypeAddAttributes a2f restyp + else + cabsTypeAddAttributes a2f + (cabsTypeAddAttributes a1f restyp) + | TPtr ((TFun _ as tf), ap) when not !msvcMode -> + if a1fadded then + TPtr(cabsTypeAddAttributes a2f tf, ap) + else + TPtr(cabsTypeAddAttributes a2f + (cabsTypeAddAttributes a1f tf), ap) + | _ -> + if a1f <> [] && not a1fadded then + E.s (error "Invalid position for (prefix) function type attributes:%a" + d_attrlist a1f); + if a2f <> [] then + E.s (error "Invalid position for (post) function type attributes:%a" + d_attrlist a2f); + restyp + in +(* + ignore (E.log "restyp' = %a\n" d_type restyp'); +*) + (* Now add the name attributes and return *) + restyp', cabsAddAttributes a1n (cabsAddAttributes a2n nattr) + + | A.PTR (al, d) -> + let al' = doAttributes al in + let an, af, at = partitionAttributes AttrType al' in + (* Now recurse *) + let restyp, nattr = doDeclType (TPtr(bt, at)) acc d in + (* See if we can do anything with function type attributes *) + let restyp' = + match unrollType restyp with + TFun _ -> cabsTypeAddAttributes af restyp + | TPtr((TFun _ as tf), ap) -> + TPtr(cabsTypeAddAttributes af tf, ap) + | _ -> + if af <> [] then + E.s (error "Invalid position for function type attributes:%a" + d_attrlist af); + restyp + in + (* Now add the name attributes and return *) + restyp', cabsAddAttributes an nattr + + + | A.ARRAY (d, al, len) -> + let lo = + match len with + A.NOTHING -> None + | _ -> + let len' = doPureExp len in + let _, len'' = castTo (typeOf len') intType len' in + let elsz = + try (bitsSizeOf bt + 7) / 8 + with _ -> 1 (** We get this if we cannot compute the size of + * one element. This can happen, when we define + * an extern, for example. We use 1 for now *) + in + (match constFold true len' with + Const(CInt64(i, _, _)) -> + if i < 0L then + E.s (error "Length of array is negative\n"); + if Int64.mul i (Int64.of_int elsz) >= 0x80000000L then + E.s (error "Length of array is too large\n") + + + | l -> + if isConstant l then + (* e.g., there may be a float constant involved. + * We'll leave it to the user to ensure the length is + * non-negative, etc.*) + ignore(warn "Unable to do constant-folding on array length %a. Some CIL operations on this array may fail." + d_exp l) + else + E.s (error "Length of array is not a constant: %a\n" + d_exp l)); + Some len'' + in + let al' = doAttributes al in + doDeclType (TArray(bt, lo, al')) acc d + + | A.PROTO (d, args, isva) -> + (* Start a scope for the parameter names *) + enterScope (); + (* Intercept the old-style use of varargs.h. On GCC this means that + * we have ellipsis and a last argument "builtin_va_alist: + * builtin_va_alist_t". On MSVC we do not have the ellipsis and we + * have a last argument "va_alist: va_list" *) + let args', isva' = + if args != [] && !msvcMode = not isva then begin + let newisva = ref isva in + let rec doLast = function + [([A.SpecType (A.Tnamed atn)], (an, A.JUSTBASE, [], _))] + when isOldStyleVarArgTypeName atn && + isOldStyleVarArgName an -> begin + (* Turn it into a vararg *) + newisva := true; + (* And forget about this argument *) + [] + end + + | a :: rest -> a :: doLast rest + | [] -> [] + in + let args' = doLast args in + (args', !newisva) + end else (args, isva) + in + (* Make the argument as for a formal *) + let doOneArg (s, (n, ndt, a, cloc)) : varinfo = + let s' = doSpecList n s in + let ndt' = match isVariableSizedArray ndt with + None -> ndt + | Some (ndt', se, len) -> + (* If this is a variable-sized array, we replace the array + type with a pointer type. This is the defined behavior + for array parameters, so we do not need to add this to + varSizeArrays, fix sizeofs, etc. *) + if isNotEmpty se then + E.s (error "array parameter: length not pure"); + ndt' + in + let vi = makeVarInfoCabs ~isformal:true ~isglobal:false + (convLoc cloc) s' (n,ndt',a) in + (* Add the formal to the environment, so it can be referenced by + other formals (e.g. in an array type, although that will be + changed to a pointer later, or though typeof). *) + addLocalToEnv vi.vname (EnvVar vi); + vi + in + let targs : varinfo list option = + match List.map doOneArg args' with + | [] -> None (* No argument list *) + | [t] when isVoidType t.vtype -> + Some [] + | l -> Some l + in + exitScope (); + (* Turn [] types into pointers in the arguments and the result type. + * Turn function types into pointers to respective. This simplifies + * our life a lot, and is what the standard requires. *) + let rec fixupArgumentTypes (argidx: int) (args: varinfo list) : unit = + match args with + [] -> () + | a :: args' -> + (match unrollType a.vtype with + TArray(t,_,attr) -> a.vtype <- TPtr(t, attr) + | TFun _ -> a.vtype <- TPtr(a.vtype, []) + | TComp (comp, _) -> begin + match isTransparentUnion a.vtype with + None -> () + | Some fstfield -> + transparentUnionArgs := + (argidx, a.vtype) :: !transparentUnionArgs; + a.vtype <- fstfield.ftype; + end + | _ -> ()); + fixupArgumentTypes (argidx + 1) args' + in + let args = + match targs with + None -> None + | Some argl -> + fixupArgumentTypes 0 argl; + Some (List.map (fun a -> (a.vname, a.vtype, a.vattr)) argl) + in + let tres = + match unrollType bt with + TArray(t,_,attr) -> TPtr(t, attr) + | _ -> bt + in + doDeclType (TFun (tres, args, isva', [])) acc d + + in + doDeclType bt [] dt + +(* If this is a declarator for a variable size array then turn it into a + pointer type and a length *) +and isVariableSizedArray (dt: A.decl_type) + : (A.decl_type * chunk * exp) option = + let res = ref None in + let rec findArray = function + ARRAY (JUSTBASE, al, lo) when lo != A.NOTHING -> + (* Try to compile the expression to a constant *) + let (se, e', _) = doExp true lo (AExp (Some intType)) in + if isNotEmpty se || not (isConstant e') then begin + res := Some (se, e'); + PTR (al, JUSTBASE) + end else + ARRAY (JUSTBASE, al, lo) + | ARRAY (dt, al, lo) -> ARRAY (findArray dt, al, lo) + | PTR (al, dt) -> PTR (al, findArray dt) + | JUSTBASE -> JUSTBASE + | PARENTYPE (prea, dt, posta) -> PARENTYPE (prea, findArray dt, posta) + | PROTO (dt, f, a) -> PROTO (findArray dt, f, a) + in + let dt' = findArray dt in + match !res with + None -> None + | Some (se, e) -> Some (dt', se, e) + +and doOnlyType (specs: A.spec_elem list) (dt: A.decl_type) : typ = + let bt',sto,inl,attrs = doSpecList "" specs in + if sto <> NoStorage || inl then + E.s (error "Storage or inline specifier in type only"); + let tres, nattr = doType AttrType bt' (A.PARENTYPE(attrs, dt, [])) in + if nattr <> [] then + E.s (error "Name attributes in only_type: %a" + d_attrlist nattr); + tres + + +and makeCompType (isstruct: bool) + (n: string) + (nglist: A.field_group list) + (a: attribute list) = + (* Make a new name for the structure *) + let kind = if isstruct then "struct" else "union" in + let n', _ = newAlphaName true kind n in + (* Create the self cell for use in fields and forward references. Or maybe + * one exists already from a forward reference *) + let comp, _ = createCompInfo isstruct n' in + let doFieldGroup ((s: A.spec_elem list), + (nl: (A.name * A.expression option) list)) : 'a list = + (* Do the specifiers exactly once *) + let sugg = match nl with + [] -> "" + | ((n, _, _, _), _) :: _ -> n + in + let bt, sto, inl, attrs = doSpecList sugg s in + (* Do the fields *) + let makeFieldInfo + (((n,ndt,a,cloc) : A.name), (widtho : A.expression option)) + : fieldinfo = + if sto <> NoStorage || inl then + E.s (error "Storage or inline not allowed for fields"); + let ftype, nattr = + doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in + (* check for fields whose type is an undefined struct. This rules + out circularity: + struct C1 { struct C2 c2; }; //This line is now an error. + struct C2 { struct C1 c1; int dummy; }; + *) + (match unrollType ftype with + TComp (ci',_) when not ci'.cdefined -> + E.s (error "Type of field %s is an undefined struct.\n" n) + | _ -> ()); + let width = + match widtho with + None -> None + | Some w -> begin + (match unrollType ftype with + TInt (ikind, a) -> () + | TEnum _ -> () + | _ -> E.s (error "Base type for bitfield is not an integer type")); + match isIntegerConstant w with + Some n -> Some n + | None -> E.s (error "bitfield width is not an integer constant") + end + in + (* If the field is unnamed and its type is a structure of union type + * then give it a distinguished name *) + let n' = + if n = missingFieldName then begin + match unrollType ftype with + TComp _ -> begin + incr annonCompFieldNameId; + annonCompFieldName ^ (string_of_int !annonCompFieldNameId) + end + | _ -> n + end else + n + in + { fcomp = comp; + fname = n'; + ftype = ftype; + fbitfield = width; + fattr = nattr; + floc = convLoc cloc + } + in + List.map makeFieldInfo nl + in + + + let flds = List.concat (List.map doFieldGroup nglist) in + if comp.cfields <> [] then begin + (* This appears to be a multiply defined structure. This can happen from + * a construct like "typedef struct foo { ... } A, B;". This is dangerous + * because at the time B is processed some forward references in { ... } + * appear as backward references, which coild lead to circularity in + * the type structure. We do a thourough check and then we reuse the type + * for A *) + let fieldsSig fs = List.map (fun f -> typeSig f.ftype) fs in + if not (Util.equals (fieldsSig comp.cfields) (fieldsSig flds)) then + ignore (error "%s seems to be multiply defined" (compFullName comp)) + end else + comp.cfields <- flds; + +(* ignore (E.log "makeComp: %s: %a\n" comp.cname d_attrlist a); *) + comp.cattr <- a; + let res = TComp (comp, []) in + (* This compinfo is defined, even if there are no fields *) + comp.cdefined <- true; + (* Create a typedef for this one *) + cabsPushGlobal (GCompTag (comp, !currentLoc)); + + (* There must be a self cell created for this already *) + addLocalToEnv (kindPlusName kind n) (EnvTyp res); + (* Now create a typedef with just this type *) + res + +and preprocessCast (specs: A.specifier) + (dt: A.decl_type) + (ie: A.init_expression) + : A.specifier * A.decl_type * A.init_expression = + let typ = doOnlyType specs dt in + (* If we are casting to a union type then we have to treat this as a + * constructor expression. This is to handle the gcc extension that allows + * cast from a type of a field to the type of the union *) + let ie' = + match unrollType typ, ie with + TComp (c, _), A.SINGLE_INIT _ when not c.cstruct -> + A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field", + A.NEXT_INIT), + ie)] + | _, _ -> ie + in + (* Maybe specs contains an unnamed composite. Replace with the name so that + * when we do again the specs we get the right name *) + let specs1 = + match typ with + TComp (ci, _) -> + List.map + (function + A.SpecType (A.Tstruct ("", flds, [])) -> + A.SpecType (A.Tstruct (ci.cname, None, [])) + | A.SpecType (A.Tunion ("", flds, [])) -> + A.SpecType (A.Tunion (ci.cname, None, [])) + | s -> s) specs + | _ -> specs + in + specs1, dt, ie' + +and getIntConstExp (aexp) : exp = + let c, e, _ = doExp true aexp (AExp None) in + if not (isEmpty c) then + E.s (error "Constant expression %a has effects" d_exp e); + match e with + (* first, filter for those Const exps that are integers *) + | Const (CInt64 _ ) -> e + | Const (CEnum _) -> e + | Const (CChr i) -> Const(charConstToInt i) + + (* other Const expressions are not ok *) + | Const _ -> E.s (error "Expected integer constant and got %a" d_exp e) + + (* now, anything else that 'doExp true' returned is ok (provided + that it didn't yield side effects); this includes, in particular, + the various sizeof and alignof expression kinds *) + | _ -> e + +(* this is like 'isIntConstExp', but retrieves the actual integer + * the expression denotes; I have not extended it to work with + * sizeof/alignof since (for CCured) we can't const-eval those, + * and it's not clear whether they can be bitfield width specifiers + * anyway (since that's where this function is used) *) +and isIntegerConstant (aexp) : int option = + match doExp true aexp (AExp None) with + (c, e, _) when isEmpty c -> begin + match isInteger e with + Some i64 -> Some (Int64.to_int i64) + | _ -> None + end + | _ -> None + + (* Process an expression and in the process do some type checking, + * extract the effects as separate statements *) +and doExp (asconst: bool) (* This expression is used as a constant *) + (e: A.expression) + (what: expAction) : (chunk * exp * typ) = + (* A subexpression of array type is automatically turned into StartOf(e). + * Similarly an expression of function type is turned into AddrOf. So + * essentially doExp should never return things of type TFun or TArray *) + let processArrayFun e t = + match e, unrollType t with + (Lval(lv) | CastE(_, Lval lv)), TArray(tbase, _, a) -> + mkStartOfAndMark lv, TPtr(tbase, a) + | (Lval(lv) | CastE(_, Lval lv)), TFun _ -> + mkAddrOfAndMark lv, TPtr(t, []) + | _, (TArray _ | TFun _) -> + E.s (error "Array or function expression is not lval: %a@!" + d_plainexp e) + | _ -> e, t + in + (* Before we return we call finishExp *) + let finishExp ?(newWhat=what) + (se: chunk) (e: exp) (t: typ) : chunk * exp * typ = + match newWhat with + ADrop -> (se, e, t) + | AExpLeaveArrayFun -> + (se, e, t) (* It is important that we do not do "processArrayFun" in + * this case. We exploit this when we process the typeOf + * construct *) + | AExp _ -> + let (e', t') = processArrayFun e t in +(* + ignore (E.log "finishExp: e'=%a, t'=%a\n" + d_exp e' d_type t'); +*) + (se, e', t') + + | ASet (lv, lvt) -> begin + (* See if the set was done already *) + match e with + Lval(lv') when lv == lv' -> + (se, e, t) + | _ -> + let (e', t') = processArrayFun e t in + let (t'', e'') = castTo t' lvt e' in +(* + ignore (E.log "finishExp: e = %a\n e'' = %a\n" d_plainexp e d_plainexp e''); +*) + (se +++ (Set(lv, e'', !currentLoc)), e'', t'') + end + in + let rec findField (n: string) (fidlist: fieldinfo list) : offset = + (* Depth first search for the field. This appears to be what GCC does. + * MSVC checks that there are no ambiguous field names, so it does not + * matter how we search *) + let rec search = function + [] -> NoOffset (* Did not find *) + | fid :: rest when fid.fname = n -> Field(fid, NoOffset) + | fid :: rest when prefix annonCompFieldName fid.fname -> begin + match unrollType fid.ftype with + TComp (ci, _) -> + let off = search ci.cfields in + if off = NoOffset then + search rest (* Continue searching *) + else + Field (fid, off) + | _ -> E.s (bug "unnamed field type is not a struct/union") + end + | _ :: rest -> search rest + in + let off = search fidlist in + if off = NoOffset then + E.s (error "Cannot find field %s" n); + off + in + try + match e with + | A.NOTHING when what = ADrop -> finishExp empty (integer 0) intType + | A.NOTHING -> + let res = Const(CStr "exp_nothing") in + finishExp empty res (typeOf res) + + (* Do the potential lvalues first *) + | A.VARIABLE n -> begin + (* Look up in the environment *) + try + let envdata = H.find env n in + match envdata with + EnvVar vi, _ -> + (* if isconst && + not (isFunctionType vi.vtype) && + not (isArrayType vi.vtype)then + E.s (error "variable appears in constant"); *) + finishExp empty (Lval(var vi)) vi.vtype + | EnvEnum (tag, typ), _ -> + if !Cil.lowerConstants then + finishExp empty tag typ + else begin + let ei = + match unrollType typ with + TEnum(ei, _) -> ei + | _ -> assert false + in + finishExp empty (Const (CEnum(tag, n, ei))) typ + end + + | _ -> raise Not_found + with Not_found -> begin + if isOldStyleVarArgName n then + E.s (error "Cannot resolve variable %s. This could be a CIL bug due to the handling of old-style variable argument functions.\n" n) + else + E.s (error "Cannot resolve variable %s.\n" n) + end + end + | A.INDEX (e1, e2) -> begin + (* Recall that doExp turns arrays into StartOf pointers *) + let (se1, e1', t1) = doExp false e1 (AExp None) in + let (se2, e2', t2) = doExp false e2 (AExp None) in + let se = se1 @@ se2 in + let (e1'', t1, e2'', tresult) = + (* Either e1 or e2 can be the pointer *) + match unrollType t1, unrollType t2 with + TPtr(t1e,_), (TInt _|TEnum _) -> e1', t1, e2', t1e + | (TInt _|TEnum _), TPtr(t2e,_) -> e2', t2, e1', t2e + | _ -> + E.s (error + "Expecting a pointer type in index:@! t1=%a@!t2=%a@!" + d_plaintype t1 d_plaintype t2) + in + (* We have to distinguish the construction based on the type of e1'' *) + let res = + match e1'' with + StartOf array -> (* A real array indexing operation *) + addOffsetLval (Index(e2'', NoOffset)) array + | _ -> (* Turn into *(e1 + e2) *) + mkMem (BinOp(IndexPI, e1'', e2'', t1)) NoOffset + in + (* Do some optimization of StartOf *) + finishExp se (Lval res) tresult + + end + | A.UNARY (A.MEMOF, e) -> + if asconst then + ignore (warn "MEMOF in constant"); + let (se, e', t) = doExp false e (AExp None) in + let tresult = + match unrollType t with + | TPtr(te, _) -> te + | _ -> E.s (error "Expecting a pointer type in *. Got %a@!" + d_plaintype t) + in + finishExp se + (Lval (mkMem e' NoOffset)) + tresult + + (* e.str = (& e + off(str)). If e = (be + beoff) then e.str = (be + * + beoff + off(str)) *) + | A.MEMBEROF (e, str) -> + (* member of is actually allowed if we only take the address *) + (* if isconst then + E.s (error "MEMBEROF in constant"); *) + let (se, e', t') = doExp false e (AExp None) in + let lv = + match e' with + Lval x -> x + | CastE(_, Lval x) -> x + | _ -> E.s (error "Expected an lval in MEMBEROF (field %s)" str) + in + let field_offset = + match unrollType t' with + TComp (comp, _) -> findField str comp.cfields + | _ -> E.s (error "expecting a struct with field %s" str) + in + let lv' = Lval(addOffsetLval field_offset lv) in + let field_type = typeOf lv' in + finishExp se lv' field_type + + (* e->str = * (e + off(str)) *) + | A.MEMBEROFPTR (e, str) -> + if asconst then + ignore (warn "MEMBEROFPTR in constant"); + let (se, e', t') = doExp false e (AExp None) in + let pointedt = + match unrollType t' with + TPtr(t1, _) -> t1 + | TArray(t1,_,_) -> t1 + | _ -> E.s (error "expecting a pointer to a struct") + in + let field_offset = + match unrollType pointedt with + TComp (comp, _) -> findField str comp.cfields + | x -> + E.s (error + "expecting a struct with field %s. Found %a. t1 is %a" + str d_type x d_type t') + in + let lv' = Lval (mkMem e' field_offset) in + let field_type = typeOf lv' in + finishExp se lv' field_type + + | A.CONSTANT ct -> begin + let hasSuffix str = + let l = String.length str in + fun s -> + let ls = String.length s in + l >= ls && s = String.uppercase (String.sub str (l - ls) ls) + in + match ct with + A.CONST_INT str -> begin + let res = parseInt str in + finishExp empty res (typeOf res) + end + +(* + | A.CONST_WSTRING wstr -> + let len = List.length wstr in + let wchar_t = !wcharType in + (* We will make an array big enough to contain the wide + * characters and the wide-null terminator *) + let ws_t = TArray(wchar_t, Some (integer len), []) in + let ws = + makeGlobalVar ("wide_string" ^ string_of_int !lastStructId) + ws_t + in + ws.vstorage <- Static; + incr lastStructId; + (* Make the initializer. Idx is a wide_char index. *) + let rec loop (idx: int) (s: int64 list) = + match s with + [] -> [] + | wc::rest -> + let wc_cilexp = Const (CInt64(wc, IInt, None)) in + (Index(integer idx, NoOffset), + SingleInit (mkCast wc_cilexp wchar_t)) + :: loop (idx + 1) rest + in + (* Add the definition for the array *) + cabsPushGlobal (GVar(ws, + {init = Some (CompoundInit(ws_t, + loop 0 wstr))}, + !currentLoc)); + finishExp empty (StartOf(Var ws, NoOffset)) + (TPtr(wchar_t, [])) + *) + + | A.CONST_WSTRING (ws: int64 list) -> + let res = Const(CWStr ((* intlist_to_wstring *) ws)) in + finishExp empty res (typeOf res) + + | A.CONST_STRING s -> + (* Maybe we burried __FUNCTION__ in there *) + let s' = + try + let start = String.index s (Char.chr 0) in + let l = String.length s in + let tofind = (String.make 1 (Char.chr 0)) ^ "__FUNCTION__" in + let past = start + String.length tofind in + if past <= l && + String.sub s start (String.length tofind) = tofind then + (if start > 0 then String.sub s 0 start else "") ^ + !currentFunctionFDEC.svar.vname ^ + (if past < l then String.sub s past (l - past) else "") + else + s + with Not_found -> s + in + let res = Const(CStr s') in + finishExp empty res (typeOf res) + + | A.CONST_CHAR char_list -> + let a, b = (interpret_character_constant char_list) in + finishExp empty (Const a) b + + | A.CONST_WCHAR char_list -> + (* matth: I can't see a reason for a list of more than one char + * here, since the kinteger64 below will take only the lower 16 + * bits of value. ('abc' makes sense, because CHAR constants have + * type int, and so more than one char may be needed to represent + * the value. But L'abc' has type wchar, and so is equivalent to + * L'c'). But gcc allows L'abc', so I'll leave this here in case + * I'm missing some architecture dependent behavior. *) + let value = reduce_multichar !wcharType char_list in + let result = kinteger64 !wcharKind value in + finishExp empty result (typeOf result) + + | A.CONST_FLOAT str -> begin + (* Maybe it ends in U or UL. Strip those *) + let l = String.length str in + let hasSuffix = hasSuffix str in + let baseint, kind = + if hasSuffix "L" then + String.sub str 0 (l - 1), FLongDouble + else if hasSuffix "F" then + String.sub str 0 (l - 1), FFloat + else if hasSuffix "D" then + String.sub str 0 (l - 1), FDouble + else + str, FDouble + in + try + finishExp empty + (Const(CReal(float_of_string baseint, kind, + Some str))) + (TFloat(kind,[])) + with e -> begin + ignore (E.log "float_of_string %s (%s)\n" str + (Printexc.to_string e)); + let res = Const(CStr "booo CONS_FLOAT") in + finishExp empty res (typeOf res) + end + end + end + + | A.TYPE_SIZEOF (bt, dt) -> + let typ = doOnlyType bt dt in + finishExp empty (SizeOf(typ)) !typeOfSizeOf + + (* Intercept the sizeof("string") *) + | A.EXPR_SIZEOF (A.CONSTANT (A.CONST_STRING s)) -> begin + (* Process the string first *) + match doExp asconst (A.CONSTANT (A.CONST_STRING s)) (AExp None) with + _, Const(CStr s), _ -> + finishExp empty (SizeOfStr s) !typeOfSizeOf + | _ -> E.s (bug "cabs2cil: sizeOfStr") + end + + | A.EXPR_SIZEOF e -> + (* Allow non-constants in sizeof *) + (* Do not convert arrays and functions into pointers. *) + let (se, e', t) = doExp false e AExpLeaveArrayFun in +(* + ignore (E.log "sizeof: %a e'=%a, t=%a\n" + d_loc !currentLoc d_plainexp e' d_type t); +*) + (* !!!! The book says that the expression is not evaluated, so we + * drop the potential side-effects + if isNotEmpty se then + ignore (warn "Warning: Dropping side-effect in EXPR_SIZEOF\n"); +*) + let size = + match e' with (* If we are taking the sizeof an + * array we must drop the StartOf *) + StartOf(lv) -> SizeOfE (Lval(lv)) + + (* Maybe we are taking the sizeof for a CStr. In that case we + * mean the pointer to the start of the string *) + | Const(CStr _) -> SizeOf (charPtrType) + + (* Maybe we are taking the sizeof a variable-sized array *) + | Lval (Var vi, NoOffset) -> begin + try + IH.find varSizeArrays vi.vid + with Not_found -> SizeOfE e' + end + | _ -> SizeOfE e' + in + finishExp empty size !typeOfSizeOf + + | A.TYPE_ALIGNOF (bt, dt) -> + let typ = doOnlyType bt dt in + finishExp empty (AlignOf(typ)) !typeOfSizeOf + + | A.EXPR_ALIGNOF e -> + let (se, e', t) = doExp false e AExpLeaveArrayFun in + (* !!!! The book says that the expression is not evaluated, so we + * drop the potential side-effects + if isNotEmpty se then + ignore (warn "Warning: Dropping side-effect in EXPR_ALIGNOF\n"); +*) + let e'' = + match e' with (* If we are taking the alignof an + * array we must drop the StartOf *) + StartOf(lv) -> Lval(lv) + + | _ -> e' + in + finishExp empty (AlignOfE(e'')) !typeOfSizeOf + + | A.CAST ((specs, dt), ie) -> + let s', dt', ie' = preprocessCast specs dt ie in + (* We know now that we can do s' and dt' many times *) + let typ = doOnlyType s' dt' in + let what' = + match what with + AExp (Some _) -> AExp (Some typ) + | AExp None -> what + | ADrop | AExpLeaveArrayFun -> what + | ASet (lv, lvt) -> + (* If the cast from typ to lvt would be dropped, then we + * continue with a Set *) + if false && Util.equals (typeSig typ) (typeSig lvt) then + what + else + AExp None (* We'll create a temporary *) + in + (* Remember here if we have done the Set *) + let (se, e', t'), (needcast: bool) = + match ie' with + A.SINGLE_INIT e -> doExp asconst e what', true + + | A.NO_INIT -> E.s (error "missing expression in cast") + + | A.COMPOUND_INIT _ -> begin + (* Pretend that we are declaring and initializing a brand new + * variable *) + let newvar = "__constr_expr_" ^ string_of_int (!constrExprId) in + incr constrExprId; + let spec_res = doSpecList "" s' in + let se1 = + if !scopes == [] then begin + ignore (createGlobal spec_res + ((newvar, dt', [], cabslu), ie')); + empty + end else + createLocal spec_res ((newvar, dt', [], cabslu), ie') + in + (* Now pretend that e is just a reference to the newly created + * variable *) + let se, e', t' = doExp asconst (A.VARIABLE newvar) what' in + (* If typ is an array then the doExp above has already added a + * StartOf. We must undo that now so that it is done once by + * the finishExp at the end of this case *) + let e2, t2 = + match unrollType typ, e' with + TArray _, StartOf lv -> Lval lv, typ + | _, _ -> e', t' + in + (* If we are here, then the type t2 is guaranteed to match the + * type of the expression e2, so we do not need a cast. We have + * to worry about this because otherwise, we might need to cast + * between arrays or structures. *) + (se1 @@ se, e2, t2), false + end + in + let (t'', e'') = + match typ with + TVoid _ when what' = ADrop -> (t', e') (* strange GNU thing *) + | _ -> + (* Do this to check the cast, unless we are sure that we do not + * need the check. *) + let newtyp, newexp = + if needcast then + castTo ~fromsource:true t' typ e' + else + t', e' + in + newtyp, newexp + in + finishExp se e'' t'' + + | A.UNARY(A.MINUS, e) -> + let (se, e', t) = doExp asconst e (AExp None) in + if isIntegralType t then + let tres = integralPromotion t in + let e'' = + match e' with + | Const(CInt64(i, ik, _)) -> kinteger64 ik (Int64.neg i) + | _ -> UnOp(Neg, mkCastT e' t tres, tres) + in + finishExp se e'' tres + else + if isArithmeticType t then + finishExp se (UnOp(Neg,e',t)) t + else + E.s (error "Unary - on a non-arithmetic type") + + | A.UNARY(A.BNOT, e) -> + let (se, e', t) = doExp asconst e (AExp None) in + if isIntegralType t then + let tres = integralPromotion t in + let e'' = UnOp(BNot, mkCastT e' t tres, tres) in + finishExp se e'' tres + else + E.s (error "Unary ~ on a non-integral type") + + | A.UNARY(A.PLUS, e) -> doExp asconst e what + + + | A.UNARY(A.ADDROF, e) -> begin + match e with + A.COMMA el -> (* GCC extension *) + doExp false + (A.COMMA (replaceLastInList el (fun e -> A.UNARY(A.ADDROF, e)))) + what + | A.QUESTION (e1, e2, e3) -> (* GCC extension *) + doExp false + (A.QUESTION (e1, A.UNARY(A.ADDROF, e2), A.UNARY(A.ADDROF, e3))) + what + | A.VARIABLE s when + isOldStyleVarArgName s + && (match !currentFunctionFDEC.svar.vtype with + TFun(_, _, true, _) -> true | _ -> false) -> + (* We are in an old-style variable argument function and we are + * taking the address of the argument that was removed while + * processing the function type. We compute the address based on + * the address of the last real argument *) + if !msvcMode then begin + let rec getLast = function + [] -> E.s (unimp "old-style variable argument function without real arguments") + | [a] -> a + | _ :: rest -> getLast rest + in + let last = getLast !currentFunctionFDEC.sformals in + let res = mkAddrOfAndMark (var last) in + let tres = typeOf res in + let tres', res' = castTo tres (TInt(IULong, [])) res in + (* Now we must add to this address to point to the next + * argument. Round up to a multiple of 4 *) + let sizeOfLast = + (((bitsSizeOf last.vtype) + 31) / 32) * 4 + in + let res'' = + BinOp(PlusA, res', kinteger IULong sizeOfLast, tres') + in + finishExp empty res'' tres' + end else begin (* On GCC the only reliable way to do this is to + * call builtin_next_arg. If we take the address of + * a local we are going to get the address of a copy + * of the local ! *) + + doExp asconst + (A.CALL (A.VARIABLE "__builtin_next_arg", + [A.CONSTANT (A.CONST_INT "0")])) + what + end + + | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) + A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | + A.CAST (_, A.COMPOUND_INIT _)) -> begin + let (se, e', t) = doExp false e (AExp None) in + (* ignore (E.log "ADDROF on %a : %a\n" d_plainexp e' + d_plaintype t); *) + match e' with + ( Lval x | CastE(_, Lval x)) -> + finishExp se (mkAddrOfAndMark x) (TPtr(t, [])) + + | StartOf (lv) -> + let tres = TPtr(typeOfLval lv, []) in (* pointer to array *) + finishExp se (mkAddrOfAndMark lv) tres + + (* Function names are converted into pointers to the function. + * Taking the address-of again does not change things *) + | AddrOf (Var v, NoOffset) when isFunctionType v.vtype -> + finishExp se e' t + + | _ -> E.s (error "Expected lval for ADDROF. Got %a@!" + d_plainexp e') + end + | _ -> E.s (error "Unexpected operand for addrof") + end + | A.UNARY((A.PREINCR|A.PREDECR) as uop, e) -> begin + match e with + A.COMMA el -> (* GCC extension *) + doExp asconst + (A.COMMA (replaceLastInList el + (fun e -> A.UNARY(uop, e)))) + what + | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) + doExp asconst + (A.QUESTION (e1, A.UNARY(uop, e2q), + A.UNARY(uop, e3q))) + what + + | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) + A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | + A.CAST _ (* A GCC extension *)) -> begin + let uop' = if uop = A.PREINCR then PlusA else MinusA in + if asconst then + ignore (warn "PREINCR or PREDECR in constant"); + let (se, e', t) = doExp false e (AExp None) in + let lv = + match e' with + Lval x -> x + | CastE (_, Lval x) -> x (* A GCC extension. The operation is + * done at the cast type. The result + * is also of the cast type *) + | _ -> E.s (error "Expected lval for ++ or --") + in + let tresult, result = doBinOp uop' e' t one intType in + finishExp (se +++ (Set(lv, mkCastT result tresult t, + !currentLoc))) + e' + tresult (* Should this be t instead ??? *) + end + | _ -> E.s (error "Unexpected operand for prefix -- or ++") + end + + | A.UNARY((A.POSINCR|A.POSDECR) as uop, e) -> begin + match e with + A.COMMA el -> (* GCC extension *) + doExp asconst + (A.COMMA (replaceLastInList el + (fun e -> A.UNARY(uop, e)))) + what + | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) + doExp asconst + (A.QUESTION (e1, A.UNARY(uop, e2q), A.UNARY(uop, e3q))) + what + + | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) + A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | + A.CAST _ (* A GCC extension *) ) -> begin + if asconst then + ignore (warn "POSTINCR or POSTDECR in constant"); + (* If we do not drop the result then we must save the value *) + let uop' = if uop = A.POSINCR then PlusA else MinusA in + let (se, e', t) = doExp false e (AExp None) in + let lv = + match e' with + Lval x -> x + | CastE (_, Lval x) -> x (* GCC extension. The addition must + * be be done at the cast type. The + * result of this is also of the cast + * type *) + | _ -> E.s (error "Expected lval for ++ or --") + in + let tresult, opresult = doBinOp uop' e' t one intType in + let se', result = + if what <> ADrop then + let tmp = newTempVar t in + se +++ (Set(var tmp, e', !currentLoc)), Lval(var tmp) + else + se, e' + in + finishExp + (se' +++ (Set(lv, mkCastT opresult tresult t, + !currentLoc))) + result + tresult (* Should this be t instead ??? *) + end + | _ -> E.s (error "Unexpected operand for suffix ++ or --") + end + + | A.BINARY(A.ASSIGN, e1, e2) -> begin + match e1 with + A.COMMA el -> (* GCC extension *) + doExp asconst + (A.COMMA (replaceLastInList el + (fun e -> A.BINARY(A.ASSIGN, e, e2)))) + what + | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) + doExp asconst + (A.QUESTION (e1, A.BINARY(A.ASSIGN, e2q, e2), + A.BINARY(A.ASSIGN, e3q, e2))) + what + | A.CAST (t, A.SINGLE_INIT e) -> (* GCC extension *) + doExp asconst + (A.CAST (t, + A.SINGLE_INIT (A.BINARY(A.ASSIGN, e, + A.CAST (t, A.SINGLE_INIT e2))))) + what + + | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) + A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ ) -> begin + if asconst then ignore (warn "ASSIGN in constant"); + let (se1, e1', lvt) = doExp false e1 (AExp None) in + let lv = + match e1' with + Lval x -> x + | _ -> E.s (error "Expected lval for assignment. Got %a\n" + d_plainexp e1') + in + let (se2, e'', t'') = doExp false e2 (ASet(lv, lvt)) in + finishExp (se1 @@ se2) e1' lvt + end + | _ -> E.s (error "Invalid left operand for ASSIGN") + end + + | A.BINARY((A.ADD|A.SUB|A.MUL|A.DIV|A.MOD|A.BAND|A.BOR|A.XOR| + A.SHL|A.SHR|A.EQ|A.NE|A.LT|A.GT|A.GE|A.LE) as bop, e1, e2) -> + let bop' = convBinOp bop in + let (se1, e1', t1) = doExp asconst e1 (AExp None) in + let (se2, e2', t2) = doExp asconst e2 (AExp None) in + let tresult, result = doBinOp bop' e1' t1 e2' t2 in + finishExp (se1 @@ se2) result tresult + + (* assignment operators *) + | A.BINARY((A.ADD_ASSIGN|A.SUB_ASSIGN|A.MUL_ASSIGN|A.DIV_ASSIGN| + A.MOD_ASSIGN|A.BAND_ASSIGN|A.BOR_ASSIGN|A.SHL_ASSIGN| + A.SHR_ASSIGN|A.XOR_ASSIGN) as bop, e1, e2) -> begin + match e1 with + A.COMMA el -> (* GCC extension *) + doExp asconst + (A.COMMA (replaceLastInList el + (fun e -> A.BINARY(bop, e, e2)))) + what + | A.QUESTION (e1, e2q, e3q) -> (* GCC extension *) + doExp asconst + (A.QUESTION (e1, A.BINARY(bop, e2q, e2), + A.BINARY(bop, e3q, e2))) + what + + | (A.VARIABLE _ | A.UNARY (A.MEMOF, _) | (* Regular lvalues *) + A.INDEX _ | A.MEMBEROF _ | A.MEMBEROFPTR _ | + A.CAST _ (* GCC extension *) ) -> begin + if asconst then + ignore (warn "op_ASSIGN in constant"); + let bop' = match bop with + A.ADD_ASSIGN -> PlusA + | A.SUB_ASSIGN -> MinusA + | A.MUL_ASSIGN -> Mult + | A.DIV_ASSIGN -> Div + | A.MOD_ASSIGN -> Mod + | A.BAND_ASSIGN -> BAnd + | A.BOR_ASSIGN -> BOr + | A.XOR_ASSIGN -> BXor + | A.SHL_ASSIGN -> Shiftlt + | A.SHR_ASSIGN -> Shiftrt + | _ -> E.s (error "binary +=") + in + let (se1, e1', t1) = doExp false e1 (AExp None) in + let lv1 = + match e1' with + Lval x -> x + | CastE (_, Lval x) -> x (* GCC extension. The operation and + * the result are at the cast type *) + | _ -> E.s (error "Expected lval for assignment with arith") + in + let (se2, e2', t2) = doExp false e2 (AExp None) in + let tresult, result = doBinOp bop' e1' t1 e2' t2 in + (* We must cast the result to the type of the lv1, which may be + * different than t1 if lv1 was a Cast *) + let _, result' = castTo tresult (typeOfLval lv1) result in + (* The type of the result is the type of the left-hand side *) + finishExp (se1 @@ se2 +++ + (Set(lv1, result', !currentLoc))) + e1' + t1 + end + | _ -> E.s (error "Unexpected left operand for assignment with arith") + end + + + | A.BINARY((A.AND|A.OR), _, _) | A.UNARY(A.NOT, _) -> begin + let ce = doCondExp asconst e in + (* We must normalize the result to 0 or 1 *) + match ce with + CEExp (se, ((Const _) as c)) -> + finishExp se (if isConstTrue c then one else zero) intType + | CEExp (se, (UnOp(LNot, _, _) as e)) -> + (* already normalized to 0 or 1 *) + finishExp se e intType + | CEExp (se, e) -> + let e' = + let te = typeOf e in + let _, zte = castTo intType te zero in + BinOp(Ne, e, zte, te) + in + finishExp se e' intType + | _ -> + let tmp = var (newTempVar intType) in + finishExp (compileCondExp ce + (empty +++ (Set(tmp, integer 1, + !currentLoc))) + (empty +++ (Set(tmp, integer 0, + !currentLoc)))) + (Lval tmp) + intType + end + + | A.CALL(f, args) -> + if asconst then + ignore (warn "CALL in constant"); + let (sf, f', ft') = + match f with (* Treat the VARIABLE case separate + * becase we might be calling a + * function that does not have a + * prototype. In that case assume it + * takes INTs as arguments *) + A.VARIABLE n -> begin + try + let vi, _ = lookupVar n in + (empty, Lval(var vi), vi.vtype) (* Found. Do not use + * finishExp. Simulate what = + * AExp None *) + with Not_found -> begin + ignore (warnOpt "Calling function %s without prototype." n); + let ftype = TFun(intType, None, false, + [Attr("missingproto",[])]) in + (* Add a prototype to the environment *) + let proto, _ = + makeGlobalVarinfo false (makeGlobalVar n ftype) in + (* Make it EXTERN *) + proto.vstorage <- Extern; + IH.add noProtoFunctions proto.vid true; + (* Add it to the file as well *) + cabsPushGlobal (GVarDecl (proto, !currentLoc)); + (empty, Lval(var proto), ftype) + end + end + | _ -> doExp false f (AExp None) + in + (* Get the result type and the argument types *) + let (resType, argTypes, isvar, f'') = + match unrollType ft' with + TFun(rt,at,isvar,a) -> (rt,at,isvar,f') + | TPtr (t, _) -> begin + match unrollType t with + TFun(rt,at,isvar,a) -> (* Make the function pointer + * explicit *) + let f'' = + match f' with + AddrOf lv -> Lval(lv) + | _ -> Lval(mkMem f' NoOffset) + in + (rt,at,isvar, f'') + | x -> + E.s (error "Unexpected type of the called function %a: %a" + d_exp f' d_type x) + end + | x -> E.s (error "Unexpected type of the called function %a: %a" + d_exp f' d_type x) + in + let argTypesList = argsToList argTypes in + (* Drop certain qualifiers from the result type *) + let resType' = resType in + (* Before we do the arguments we try to intercept a few builtins. For + * these we have defined then with a different type, so we do not + * want to give warnings. We'll just leave the arguments of these + * functions alone*) + let isSpecialBuiltin = + match f'' with + Lval (Var fv, NoOffset) -> + fv.vname = "__builtin_stdarg_start" || + fv.vname = "__builtin_va_arg" || + fv.vname = "__builtin_va_start" || + fv.vname = "__builtin_expect" || + fv.vname = "__builtin_next_arg" + | _ -> false + in + + (** If the "--forceRLArgEval" flag was used, make sure + we evaluate args right-to-left. + Added by Nathan Cooprider. **) + let force_right_to_left_evaluation (c, e, t) = + (* If chunk is empty then it is not already evaluated *) + (* constants don't need to be pulled out *) + if (!forceRLArgEval && (not (isConstant e)) && + (not isSpecialBuiltin)) then + (* create a temporary *) + let tmp = newTempVar t in + (* create an instruction to give the e to the temporary *) + let i = Set(var tmp, e, !currentLoc) in + (* add the instruction to the chunk *) + (* change the expression to be the temporary *) + (c +++ i, (Lval(var tmp)), t) + else + (c, e, t) + in + (* Do the arguments. In REVERSE order !!! Both GCC and MSVC do this *) + let rec loopArgs + : (string * typ * attributes) list * A.expression list + -> (chunk * exp list) = function + | ([], []) -> (empty, []) + + | args, [] -> + if not isSpecialBuiltin then + ignore (warnOpt + "Too few arguments in call to %a." + d_exp f'); + (empty, []) + + | ((_, at, _) :: atypes, a :: args) -> + let (ss, args') = loopArgs (atypes, args) in + (* Do not cast as part of translating the argument. We let + * the castTo to do this work. This was necessary for + * test/small1/union5, in which a transparent union is passed + * as an argument *) + let (sa, a', att) = force_right_to_left_evaluation + (doExp false a (AExp None)) in + let (_, a'') = castTo att at a' in + (ss @@ sa, a'' :: args') + + | ([], args) -> (* No more types *) + if not isvar && argTypes != None && not isSpecialBuiltin then + (* Do not give a warning for functions without a prototype*) + ignore (warnOpt "Too many arguments in call to %a" d_exp f'); + let rec loop = function + [] -> (empty, []) + | a :: args -> + let (ss, args') = loop args in + let (sa, a', at) = force_right_to_left_evaluation + (doExp false a (AExp None)) in + (ss @@ sa, a' :: args') + in + loop args + in + let (sargs, args') = loopArgs (argTypesList, args) in + (* Setup some pointer to the elements of the call. We may change + * these below *) + let prechunk: chunk ref = ref (sf @@ sargs) in (* comes before *) + + (* Do we actually have a call, or an expression? *) + let piscall: bool ref = ref true in + + let pf: exp ref = ref f'' in (* function to call *) + let pargs: exp list ref = ref args' in (* arguments *) + let pis__builtin_va_arg: bool ref = ref false in + let pwhat: expAction ref = ref what in (* what to do with result *) + + let pres: exp ref = ref zero in (* If we do not have a call, this is + * the result *) + let prestype: typ ref = ref intType in + + let rec dropCasts = function CastE (_, e) -> dropCasts e | e -> e in + (* Get the name of the last formal *) + let getNameLastFormal () : string = + match !currentFunctionFDEC.svar.vtype with + TFun(_, Some args, true, _) -> begin + match List.rev args with + (last_par_name, _, _) :: _ -> last_par_name + | _ -> "" + end + | _ -> "" + in + + (* Try to intercept some builtins *) + (match !pf with + Lval(Var fv, NoOffset) -> begin + if fv.vname = "__builtin_va_arg" then begin + match !pargs with + marker :: SizeOf resTyp :: _ -> begin + (* Make a variable of the desired type *) + let destlv, destlvtyp = + match !pwhat with + ASet (lv, lvt) -> lv, lvt + | _ -> var (newTempVar resTyp), resTyp + in + pwhat := (ASet (destlv, destlvtyp)); + pargs := [marker; SizeOf resTyp; AddrOf destlv]; + pis__builtin_va_arg := true; + end + | _ -> + ignore (warn "Invalid call to %s\n" fv.vname); + end else if fv.vname = "__builtin_stdarg_start" then begin + match !pargs with + marker :: last :: [] -> begin + let isOk = + match dropCasts last with + Lval (Var lastv, NoOffset) -> + lastv.vname = getNameLastFormal () + | _ -> false + in + if not isOk then + ignore (warn "The second argument in call to %s should be the last formal argument\n" fv.vname); + + (* Check that "lastv" is indeed the last variable in the + * prototype and then drop it *) + pargs := [ marker ] + end + | _ -> + ignore (warn "Invalid call to %s\n" fv.vname); + + (* We have to turn uses of __builtin_varargs_start into uses + * of __builtin_stdarg_start (because we have dropped the + * __builtin_va_alist argument from this function) *) + + end else if fv.vname = "__builtin_varargs_start" then begin + (* Lookup the prototype for the replacement *) + let v, _ = + try lookupGlobalVar "__builtin_stdarg_start" + with Not_found -> E.s (bug "Cannot find __builtin_stdarg_start to replace %s\n" fv.vname) + in + pf := Lval (var v) + end else if fv.vname = "__builtin_next_arg" then begin + match !pargs with + last :: [] -> begin + let isOk = + match dropCasts last with + Lval (Var lastv, NoOffset) -> + lastv.vname = getNameLastFormal () + | _ -> false + in + if not isOk then + ignore (warn "The argument in call to %s should be the last formal argument\n" fv.vname); + + pargs := [ ] + end + | _ -> + ignore (warn "Invalid call to %s\n" fv.vname); + end else if fv.vname = "__builtin_constant_p" then begin + (* Drop the side-effects *) + prechunk := empty; + + (* Constant-fold the argument and see if it is a constant *) + (match !pargs with + [ arg ] -> begin + match constFold true arg with + Const _ -> piscall := false; + pres := integer 1; + prestype := intType + + | _ -> piscall := false; + pres := integer 0; + prestype := intType + end + | _ -> + ignore (warn "Invalid call to builtin_constant_p")); + end + end + | _ -> ()); + + + (* Now we must finish the call *) + if !piscall then begin + let addCall (calldest: lval option) (res: exp) (t: typ) = + prechunk := !prechunk +++ + (Call(calldest, !pf, !pargs, !currentLoc)); + pres := res; + prestype := t + in + match !pwhat with + ADrop -> addCall None zero intType + + (* Set to a variable of corresponding type *) + | ASet(lv, vtype) -> + (* Make an exception here for __builtin_va_arg *) + if !pis__builtin_va_arg then + addCall None (Lval(lv)) vtype + else + addCall (Some lv) (Lval(lv)) vtype + + | _ -> begin + let tmp, restyp' = + match !pwhat with + AExp (Some t) -> newTempVar t, t + | _ -> newTempVar resType', resType' + in + (* Remember that this variable has been created for this + * specific call. We will use this in collapseCallCast and + * above in finishCall. *) + IH.add callTempVars tmp.vid (); + addCall (Some (var tmp)) (Lval(var tmp)) restyp' + end + end; + + finishExp !prechunk !pres !prestype + + + | A.COMMA el -> + if asconst then + ignore (warn "COMMA in constant"); + let rec loop sofar = function + [e] -> + let (se, e', t') = doExp false e what in (* Pass on the action *) + (sofar @@ se, e', t') +(* + finishExp (sofar @@ se) e' t' (* does not hurt to do it twice. + * GN: it seems it does *) +*) + | e :: rest -> + let (se, _, _) = doExp false e ADrop in + loop (sofar @@ se) rest + | [] -> E.s (error "empty COMMA expression") + in + loop empty el + + | A.QUESTION (e1,e2,e3) when what = ADrop -> + if asconst then + ignore (warn "QUESTION with ADrop in constant"); + let (se3,_,_) = doExp false e3 ADrop in + let se2 = + match e2 with + A.NOTHING -> skipChunk + | _ -> let (se2,_,_) = doExp false e2 ADrop in se2 + in + finishExp (doCondition asconst e1 se2 se3) zero intType + + | A.QUESTION (e1, e2, e3) -> begin (* what is not ADrop *) + (* Compile the conditional expression *) + let ce1 = doCondExp asconst e1 in + (* Now we must find the type of both branches, in order to compute + * the type of the result *) + let se2, e2'o (* is an option. None means use e1 *), t2 = + match e2 with + A.NOTHING -> begin (* The same as the type of e1 *) + match ce1 with + CEExp (_, e1') -> empty, None, typeOf e1' (* Do not promote + to bool *) + | _ -> empty, None, intType + end + | _ -> + let se2, e2', t2 = doExp asconst e2 (AExp None) in + se2, Some e2', t2 + in + (* Do e3 for real *) + let se3, e3', t3 = doExp asconst e3 (AExp None) in + (* Compute the type of the result *) + let tresult = conditionalConversion t2 t3 in + match ce1 with + CEExp (se1, e1') when isConstFalse e1' && canDrop se2 -> + finishExp (se1 @@ se3) (snd (castTo t3 tresult e3')) tresult + | CEExp (se1, e1') when isConstTrue e1' && canDrop se3 -> + begin + match e2'o with + None -> (* use e1' *) + finishExp (se1 @@ se2) (snd (castTo t2 tresult e1')) tresult + | Some e2' -> + finishExp (se1 @@ se2) (snd (castTo t2 tresult e2')) tresult + end + + | _ -> (* Use a conditional *) begin + match e2 with + A.NOTHING -> + let tmp = var (newTempVar tresult) in + let (se1, _, _) = doExp asconst e1 (ASet(tmp, tresult)) in + let (se3, _, _) = doExp asconst e3 (ASet(tmp, tresult)) in + finishExp (se1 @@ ifChunk (Lval(tmp)) lu + skipChunk se3) + (Lval(tmp)) + tresult + | _ -> + let lv, lvt = + match what with + | ASet (lv, lvt) -> lv, lvt + | _ -> + let tmp = newTempVar tresult in + var tmp, tresult + in + (* Now do e2 and e3 for real *) + let (se2, _, _) = doExp asconst e2 (ASet(lv, lvt)) in + let (se3, _, _) = doExp asconst e3 (ASet(lv, lvt)) in + finishExp (doCondition asconst e1 se2 se3) (Lval(lv)) tresult + end + +(* + (* Do these only to collect the types *) + let se2, e2', t2' = + match e2 with + A.NOTHING -> (* A GNU thing. Use e1 as e2 *) + doExp isconst e1 (AExp None) + | _ -> doExp isconst e2 (AExp None) in + (* Do e3 for real *) + let se3, e3', t3' = doExp isconst e3 (AExp None) in + (* Compute the type of the result *) + let tresult = conditionalConversion e2' t2' e3' t3' in + if (isEmpty se2 || e2 = A.NOTHING) + && isEmpty se3 && isconst then begin + (* Use the Question. This allows Question in initializers without + * having to do constant folding *) + let se1, e1', t1 = doExp isconst e1 (AExp None) in + ignore (checkBool t1 e1'); + let e2'' = + if e2 = A.NOTHING then + mkCastT e1' t1 tresult + else mkCastT e2' t2' tresult (* We know se2 is empty *) + in + let e3'' = mkCastT e3' t3' tresult in + let resexp = + match e1' with + Const(CInt64(i, _, _)) when i <> Int64.zero -> e2'' + | Const(CInt64(z, _, _)) when z = Int64.zero -> e3'' + | _ -> Question(e1', e2'', e3'') + in + finishExp se1 resexp tresult + end else begin (* Now use a conditional *) + match e2 with + A.NOTHING -> + let tmp = var (newTempVar tresult) in + let (se1, _, _) = doExp isconst e1 (ASet(tmp, tresult)) in + let (se3, _, _) = doExp isconst e3 (ASet(tmp, tresult)) in + finishExp (se1 @@ ifChunk (Lval(tmp)) lu + skipChunk se3) + (Lval(tmp)) + tresult + | _ -> + let lv, lvt = + match what with + | ASet (lv, lvt) -> lv, lvt + | _ -> + let tmp = newTempVar tresult in + var tmp, tresult + in + (* Now do e2 and e3 for real *) + let (se2, _, _) = doExp isconst e2 (ASet(lv, lvt)) in + let (se3, _, _) = doExp isconst e3 (ASet(lv, lvt)) in + finishExp (doCondition isconst e1 se2 se3) (Lval(lv)) tresult + end +*) + end + + | A.GNU_BODY b -> begin + (* Find the last A.COMPUTATION and remember it. This one is invoked + * on the reversed list of statements. *) + let rec findLastComputation = function + s :: _ -> + let rec findLast = function + A.SEQUENCE (_, s, loc) -> findLast s + | CASE (_, s, _) -> findLast s + | CASERANGE (_, _, s, _) -> findLast s + | LABEL (_, s, _) -> findLast s + | (A.COMPUTATION _) as s -> s + | _ -> raise Not_found + in + findLast s + | [] -> raise Not_found + in + (* Save the previous data *) + let old_gnu = ! gnu_body_result in + let lastComp, isvoidbody = + match what with + ADrop -> (* We are dropping the result *) + A.NOP cabslu, true + | _ -> + try findLastComputation (List.rev b.A.bstmts), false + with Not_found -> + E.s (error "Cannot find COMPUTATION in GNU.body") + (* A.NOP cabslu, true *) + in + (* Prepare some data to be filled by doExp *) + let data : (exp * typ) option ref = ref None in + gnu_body_result := (lastComp, data); + + let se = doBody b in + + gnu_body_result := old_gnu; + match !data with + None when isvoidbody -> finishExp se zero voidType + | None -> E.s (bug "Cannot find COMPUTATION in GNU.body") + | Some (e, t) -> finishExp se e t + end + + | A.LABELADDR l -> begin (* GCC's taking the address of a label *) + let l = lookupLabel l in (* To support locallly declared labels *) + let addrval = + try H.find gotoTargetHash l + with Not_found -> begin + let res = !gotoTargetNextAddr in + incr gotoTargetNextAddr; + H.add gotoTargetHash l res; + res + end + in + finishExp empty (mkCast (integer addrval) voidPtrType) voidPtrType + end + + | A.EXPR_PATTERN _ -> E.s (E.bug "EXPR_PATTERN in cabs2cil input") + + with e -> begin + ignore (E.log "error in doExp (%s)@!" (Printexc.to_string e)); + E.hadErrors := true; + (i2c (dInstr (dprintf "booo_exp(%t)" d_thisloc) !currentLoc), + integer 0, intType) + end + +(* bop is always the arithmetic version. Change it to the appropriate pointer + * version if necessary *) +and doBinOp (bop: binop) (e1: exp) (t1: typ) (e2: exp) (t2: typ) : typ * exp = + let doArithmetic () = + let tres = arithmeticConversion t1 t2 in + (* Keep the operator since it is arithmetic *) + tres, + optConstFoldBinOp false bop (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) tres + in + let doArithmeticComp () = + let tres = arithmeticConversion t1 t2 in + (* Keep the operator since it is arithemtic *) + intType, + optConstFoldBinOp false bop + (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) intType + in + let doIntegralArithmetic () = + let tres = unrollType (arithmeticConversion t1 t2) in + match tres with + TInt _ -> + tres, + optConstFoldBinOp false bop + (mkCastT e1 t1 tres) (mkCastT e2 t2 tres) tres + | _ -> E.s (error "%a operator on a non-integer type" d_binop bop) + in + let pointerComparison e1 t1 e2 t2 = + (* XL: Do not cast both sides -- what's the point? *) + intType, + optConstFoldBinOp false bop e1 e2 intType + in + + match bop with + (Mult|Div) -> doArithmetic () + | (Mod|BAnd|BOr|BXor) -> doIntegralArithmetic () + | (Shiftlt|Shiftrt) -> (* ISO 6.5.7. Only integral promotions. The result + * has the same type as the left hand side *) + if !msvcMode then + (* MSVC has a bug. We duplicate it here *) + doIntegralArithmetic () + else + let t1' = integralPromotion t1 in + let t2' = integralPromotion t2 in + t1', + optConstFoldBinOp false bop (mkCastT e1 t1 t1') (mkCastT e2 t2 t2') t1' + + | (PlusA|MinusA) + when isArithmeticType t1 && isArithmeticType t2 -> doArithmetic () + | (Eq|Ne|Lt|Le|Ge|Gt) + when isArithmeticType t1 && isArithmeticType t2 -> + doArithmeticComp () + | PlusA when isPointerType t1 && isIntegralType t2 -> + t1, + optConstFoldBinOp false PlusPI e1 + (mkCastT e2 t2 (integralPromotion t2)) t1 + | PlusA when isIntegralType t1 && isPointerType t2 -> + t2, + optConstFoldBinOp false PlusPI e2 + (mkCastT e1 t1 (integralPromotion t1)) t2 + | MinusA when isPointerType t1 && isIntegralType t2 -> + t1, + optConstFoldBinOp false MinusPI e1 + (mkCastT e2 t2 (integralPromotion t2)) t1 + | MinusA when isPointerType t1 && isPointerType t2 -> + let commontype = t1 in + intType, + optConstFoldBinOp false MinusPP (mkCastT e1 t1 commontype) + (mkCastT e2 t2 commontype) intType + | (Le|Lt|Ge|Gt|Eq|Ne) when isPointerType t1 && isPointerType t2 -> + pointerComparison e1 t1 e2 t2 + | (Eq|Ne) when isPointerType t1 && isZero e2 -> + pointerComparison e1 t1 (mkCastT zero !upointType t1) t1 + | (Eq|Ne) when isPointerType t2 && isZero e1 -> + pointerComparison (mkCastT zero !upointType t2) t2 e2 t2 + + + | (Eq|Ne|Le|Lt|Ge|Gt) when isPointerType t1 && isArithmeticType t2 -> + ignore (warnOpt "Comparison of pointer and non-pointer"); + (* Cast both values to void * *) + doBinOp bop (mkCastT e1 t1 voidPtrType) voidPtrType + (mkCastT e2 t2 voidPtrType) voidPtrType + | (Eq|Ne|Le|Lt|Ge|Gt) when isArithmeticType t1 && isPointerType t2 -> + ignore (warnOpt "Comparison of pointer and non-pointer"); + (* Cast both values to void * *) + doBinOp bop (mkCastT e1 t1 voidPtrType) voidPtrType + (mkCastT e2 t2 voidPtrType) voidPtrType + + | _ -> E.s (error "doBinOp: %a\n" d_plainexp (BinOp(bop,e1,e2,intType))) + +(* Constant fold a conditional. This is because we want to avoid having + * conditionals in the initializers. So, we try very hard to avoid creating + * new statements. *) +and doCondExp (asconst: bool) (** Try to evaluate the conditional expression + * to TRUE or FALSE, because it occurs in a + * constant *) + (e: A.expression) : condExpRes = + let rec addChunkBeforeCE (c0: chunk) = function + CEExp (c, e) -> CEExp (c0 @@ c, e) + | CEAnd (ce1, ce2) -> CEAnd (addChunkBeforeCE c0 ce1, ce2) + | CEOr (ce1, ce2) -> CEOr (addChunkBeforeCE c0 ce1, ce2) + | CENot ce1 -> CENot (addChunkBeforeCE c0 ce1) + in + let rec canDropCE = function + CEExp (c, e) -> canDrop c + | CEAnd (ce1, ce2) | CEOr (ce1, ce2) -> canDropCE ce1 && canDropCE ce2 + | CENot (ce1) -> canDropCE ce1 + in + match e with + A.BINARY (A.AND, e1, e2) -> begin + let ce1 = doCondExp asconst e1 in + let ce2 = doCondExp asconst e2 in + match ce1, ce2 with + CEExp (se1, ((Const _) as ci1)), _ -> + if isConstTrue ci1 then + addChunkBeforeCE se1 ce2 + else + (* se2 might contain labels so we cannot always drop it *) + if canDropCE ce2 then + ce1 + else + CEAnd (ce1, ce2) + | CEExp(se1, e1'), CEExp (se2, e2') when + !useLogicalOperators && isEmpty se1 && isEmpty se2 -> + CEExp (empty, BinOp(LAnd, + mkCast e1' intType, + mkCast e2' intType, intType)) + | _ -> CEAnd (ce1, ce2) + end + + | A.BINARY (A.OR, e1, e2) -> begin + let ce1 = doCondExp asconst e1 in + let ce2 = doCondExp asconst e2 in + match ce1, ce2 with + CEExp (se1, (Const(CInt64 _) as ci1)), _ -> + if isConstFalse ci1 then + addChunkBeforeCE se1 ce2 + else + (* se2 might contain labels so we cannot drop it *) + if canDropCE ce2 then + ce1 + else + CEOr (ce1, ce2) + + | CEExp (se1, e1'), CEExp (se2, e2') when + !useLogicalOperators && isEmpty se1 && isEmpty se2 -> + CEExp (empty, BinOp(LOr, mkCast e1' intType, + mkCast e2' intType, intType)) + | _ -> CEOr (ce1, ce2) + end + + | A.UNARY(A.NOT, e1) -> begin + match doCondExp asconst e1 with + CEExp (se1, (Const _ as ci1)) -> + if isConstFalse ci1 then + CEExp (se1, one) + else + CEExp (se1, zero) + | CEExp (se1, e) when isEmpty se1 -> + let t = typeOf e in + if not ((isPointerType t) || (isArithmeticType t))then + E.s (error "Bad operand to !"); + CEExp (empty, UnOp(LNot, e, intType)) + + | ce1 -> CENot ce1 + end + + | _ -> + let (se, e, t) = doExp asconst e (AExp None) in + ignore (checkBool t e); + CEExp (se, if !lowerConstants then constFold asconst e else e) + +and compileCondExp (ce: condExpRes) (st: chunk) (sf: chunk) : chunk = + match ce with + | CEAnd (ce1, ce2) -> + let (sf1, sf2) = + (* If sf is small then will copy it *) + try (sf, duplicateChunk sf) + with Failure _ -> + let lab = newLabelName "_L" in + (gotoChunk lab lu, consLabel lab sf !currentLoc false) + in + let st' = compileCondExp ce2 st sf1 in + let sf' = sf2 in + compileCondExp ce1 st' sf' + + | CEOr (ce1, ce2) -> + let (st1, st2) = + (* If st is small then will copy it *) + try (st, duplicateChunk st) + with Failure _ -> + let lab = newLabelName "_L" in + (gotoChunk lab lu, consLabel lab st !currentLoc false) + in + let st' = st1 in + let sf' = compileCondExp ce2 st2 sf in + compileCondExp ce1 st' sf' + + | CENot ce1 -> compileCondExp ce1 sf st + + | CEExp (se, e) -> begin + match e with + Const(CInt64(i,_,_)) when i <> Int64.zero && canDrop sf -> se @@ st + | Const(CInt64(z,_,_)) when z = Int64.zero && canDrop st -> se @@ sf + | _ -> se @@ ifChunk e !currentLoc st sf + end + + +(* A special case for conditionals *) +and doCondition (isconst: bool) (* If we are in constants, we do our best to + * eliminate the conditional *) + (e: A.expression) + (st: chunk) + (sf: chunk) : chunk = + compileCondExp (doCondExp isconst e) st sf + + +and doPureExp (e : A.expression) : exp = + let (se, e', _) = doExp true e (AExp None) in + if isNotEmpty se then + E.s (error "doPureExp: not pure"); + e' + +and doInitializer + (vi: varinfo) + (inite: A.init_expression) + (* Return the accumulated chunk, the initializer and the new type (might be + * different for arrays) *) + : chunk * init * typ = + + (* Setup the pre-initializer *) + let topPreInit = ref NoInitPre in + if debugInit then + ignore (E.log "\nStarting a new initializer for %s : %a\n" + vi.vname d_type vi.vtype); + let topSetupInit (o: offset) (e: exp) = + if debugInit then + ignore (E.log " set %a := %a\n" d_lval (Var vi, o) d_exp e); + let newinit = setOneInit !topPreInit o e in + if newinit != !topPreInit then topPreInit := newinit + in + let acc, restl = + let so = makeSubobj vi vi.vtype NoOffset in + doInit vi.vglob topSetupInit so empty [ (A.NEXT_INIT, inite) ] + in + if restl <> [] then + ignore (warn "Ignoring some initializers"); + (* sm: we used to do array-size fixups here, but they only worked + * for toplevel array types; now, collectInitializer does the job, + * including for nested array types *) + let typ' = unrollType vi.vtype in + if debugInit then + ignore (E.log "Collecting the initializer for %s\n" vi.vname); + let (init, typ'') = collectInitializer !topPreInit typ' in + if debugInit then + ignore (E.log "Finished the initializer for %s\n init=%a\n typ=%a\n acc=%a\n" + vi.vname d_init init d_type typ' d_chunk acc); + acc, init, typ'' + + + +(* Consume some initializers. Watch out here. Make sure we use only + * tail-recursion because these things can be big. *) +and doInit + (isconst: bool) + (setone: offset -> exp -> unit) (* Use to announce an intializer *) + (so: subobj) + (acc: chunk) + (initl: (A.initwhat * A.init_expression) list) + + (* Return the resulting chunk along with some unused initializers *) + : chunk * (A.initwhat * A.init_expression) list = + + let whoami () = d_lval () (Var so.host, so.soOff) in + + let initl1 = + match initl with + | (A.NEXT_INIT, + A.SINGLE_INIT (A.CAST ((s, dt), ie))) :: rest -> + let s', dt', ie' = preprocessCast s dt ie in + (A.NEXT_INIT, A.SINGLE_INIT (A.CAST ((s', dt'), ie'))) :: rest + | _ -> initl + in + (* Sometimes we have a cast in front of a compound (in GCC). This + * appears as a single initializer. Ignore the cast *) + let initl2 = + match initl1 with + (what, + A.SINGLE_INIT (A.CAST (_, A.COMPOUND_INIT ci))) :: rest -> + (what, A.COMPOUND_INIT ci) :: rest + | _ -> initl1 + in + let allinitl = initl2 in + + if debugInit then begin + ignore (E.log "doInit for %t %s (current %a). Looking at: " whoami + (if so.eof then "(eof)" else "") + d_lval (Var so.host, so.curOff)); + (match allinitl with + [] -> ignore (E.log "[]") + | (what, ie) :: _ -> + withCprint + Cprint.print_init_expression (A.COMPOUND_INIT [(what, ie)])); + ignore (E.log "\n"); + end; + match unrollType so.soTyp, allinitl with + _, [] -> acc, [] (* No more initializers return *) + + (* No more subobjects *) + | _, (A.NEXT_INIT, _) :: _ when so.eof -> acc, allinitl + + + (* If we are at an array of characters and the initializer is a + * string literal (optionally enclosed in braces) then explode the + * string into characters *) + | TArray(bt, leno, _), + (A.NEXT_INIT, + (A.SINGLE_INIT(A.CONSTANT (A.CONST_STRING s))| + A.COMPOUND_INIT + [(A.NEXT_INIT, + A.SINGLE_INIT(A.CONSTANT + (A.CONST_STRING s)))])) :: restil + when (match unrollType bt with + TInt((IChar|IUChar|ISChar), _) -> true + | TInt _ -> + (*Base type is a scalar other than char. Maybe a wchar_t?*) + E.s (error "Using a string literal to initialize something other than a character array.\n") + | _ -> false (* OK, this is probably an array of strings. Handle *) + ) (* it with the other arrays below.*) + -> + let charinits = + let init c = A.NEXT_INIT, A.SINGLE_INIT(A.CONSTANT (A.CONST_CHAR [c])) + in + let collector = + (* ISO 6.7.8 para 14: final NUL added only if no size specified, or + * if there is room for it; btw, we can't rely on zero-init of + * globals, since this array might be a local variable *) + if ((isNone leno) or ((String.length s) < (integerArrayLength leno))) + then ref [init Int64.zero] + else ref [] + in + for pos = String.length s - 1 downto 0 do + collector := init (Int64.of_int (Char.code (s.[pos]))) :: !collector + done; + !collector + in + (* Create a separate object for the array *) + let so' = makeSubobj so.host so.soTyp so.soOff in + (* Go inside the array *) + let leno = integerArrayLength leno in + so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; + normalSubobj so'; + let acc', initl' = doInit isconst setone so' acc charinits in + if initl' <> [] then + ignore (warn "Too many initializers for character array %t" whoami); + (* Advance past the array *) + advanceSubobj so; + (* Continue *) + let res = doInit isconst setone so acc' restil in + res + + (* If we are at an array of WIDE characters and the initializer is a + * WIDE string literal (optionally enclosed in braces) then explore + * the WIDE string into characters *) + (* [weimer] Wed Jan 30 15:38:05 PST 2002 + * Despite what the compiler says, this match case is used and it is + * important. *) + | TArray(bt, leno, _), + (A.NEXT_INIT, + (A.SINGLE_INIT(A.CONSTANT (A.CONST_WSTRING s)) | + A.COMPOUND_INIT + [(A.NEXT_INIT, + A.SINGLE_INIT(A.CONSTANT + (A.CONST_WSTRING s)))])) :: restil + when(let bt' = unrollType bt in + match bt' with + (* compare bt to wchar_t, ignoring signed vs. unsigned *) + TInt _ when (bitsSizeOf bt') = (bitsSizeOf !wcharType) -> true + | TInt _ -> + (*Base type is a scalar other than wchar_t. Maybe a char?*) + E.s (error "Using a wide string literal to initialize something other than a wchar_t array.\n") + | _ -> false (* OK, this is probably an array of strings. Handle *) + ) (* it with the other arrays below.*) + -> + let maxWChar = (* (2**(bitsSizeOf !wcharType)) - 1 *) + Int64.sub (Int64.shift_left Int64.one (bitsSizeOf !wcharType)) + Int64.one in + let charinits = + let init c = + if (compare c maxWChar > 0) then (* if c > maxWChar *) + E.s (error "cab2cil:doInit:character 0x%Lx too big." c); + A.NEXT_INIT, + A.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c))) + in + (List.map init s) @ + ( + (* ISO 6.7.8 para 14: final NUL added only if no size specified, or + * if there is room for it; btw, we can't rely on zero-init of + * globals, since this array might be a local variable *) + if ((isNone leno) or ((List.length s) < (integerArrayLength leno))) + then [init Int64.zero] + else []) +(* + List.map + (fun c -> + if (compare c maxWChar > 0) then (* if c > maxWChar *) + E.s (error "cab2cil:doInit:character 0x%Lx too big." c) + else + (A.NEXT_INIT, + A.SINGLE_INIT(A.CONSTANT (A.CONST_INT (Int64.to_string c))))) + s +*) + in + (* Create a separate object for the array *) + let so' = makeSubobj so.host so.soTyp so.soOff in + (* Go inside the array *) + let leno = integerArrayLength leno in + so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; + normalSubobj so'; + let acc', initl' = doInit isconst setone so' acc charinits in + if initl' <> [] then + (* sm: see above regarding ISO 6.7.8 para 14, which is not implemented + * for wchar_t because, as far as I can tell, we don't even put in + * the automatic NUL (!) *) + ignore (warn "Too many initializers for wchar_t array %t" whoami); + (* Advance past the array *) + advanceSubobj so; + (* Continue *) + doInit isconst setone so acc' restil + + (* If we are at an array and we see a single initializer then it must + * be one for the first element *) + | TArray(bt, leno, al), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> + (* Grab the length if there is one *) + let leno = integerArrayLength leno in + so.stack <- InArray(so.soOff, bt, leno, ref 0) :: so.stack; + normalSubobj so; + (* Start over with the fields *) + doInit isconst setone so acc allinitl + + (* If we are at a composite and we see a single initializer of the same + * type as the composite then grab it all. If the type is not the same + * then we must go on and try to initialize the fields *) + | TComp (comp, _), (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> + let se, oneinit', t' = doExp isconst oneinit (AExp None) in + if (match unrollType t' with + TComp (comp', _) when comp'.ckey = comp.ckey -> true + | _ -> false) + then begin + (* Initialize the whole struct *) + setone so.soOff oneinit'; + (* Advance to the next subobject *) + advanceSubobj so; + doInit isconst setone so (acc @@ se) restil + end else begin (* Try to initialize fields *) + let toinit = fieldsToInit comp None in + so.stack <- InComp(so.soOff, comp, toinit) :: so.stack; + normalSubobj so; + doInit isconst setone so acc allinitl + end + + (* A scalar with a single initializer *) + | _, (A.NEXT_INIT, A.SINGLE_INIT oneinit) :: restil -> + let se, oneinit', t' = doExp isconst oneinit (AExp(Some so.soTyp)) in +(* + ignore (E.log "oneinit'=%a, t'=%a, so.soTyp=%a\n" + d_exp oneinit' d_type t' d_type so.soTyp); +*) + setone so.soOff (mkCastT oneinit' t' so.soTyp); + (* Move on *) + advanceSubobj so; + doInit isconst setone so (acc @@ se) restil + + + (* An array with a compound initializer. The initializer is for the + * array elements *) + | TArray (bt, leno, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil -> + (* Create a separate object for the array *) + let so' = makeSubobj so.host so.soTyp so.soOff in + (* Go inside the array *) + let leno = integerArrayLength leno in + so'.stack <- [InArray(so'.curOff, bt, leno, ref 0)]; + normalSubobj so'; + let acc', initl' = doInit isconst setone so' acc initl in + if initl' <> [] then + ignore (warn "Too many initializers for array %t" whoami); + (* Advance past the array *) + advanceSubobj so; + (* Continue *) + let res = doInit isconst setone so acc' restil in + res + + (* We have a designator that tells us to select the matching union field. + * This is to support a GCC extension *) + | TComp(ci, _), [(A.NEXT_INIT, + A.COMPOUND_INIT [(A.INFIELD_INIT ("___matching_field", + A.NEXT_INIT), + A.SINGLE_INIT oneinit)])] + when not ci.cstruct -> + (* Do the expression to find its type *) + let _, _, t' = doExp isconst oneinit (AExp None) in + let tsig = typeSigWithAttrs (fun _ -> []) t' in + let rec findField = function + [] -> E.s (error "Cannot find matching union field in cast") + | fi :: rest + when Util.equals (typeSigWithAttrs (fun _ -> []) fi.ftype) tsig + -> fi + | _ :: rest -> findField rest + in + let fi = findField ci.cfields in + (* Change the designator and redo *) + doInit isconst setone so acc [(A.INFIELD_INIT (fi.fname, A.NEXT_INIT), + A.SINGLE_INIT oneinit)] + + + (* A structure with a composite initializer. We initialize the fields*) + | TComp (comp, _), (A.NEXT_INIT, A.COMPOUND_INIT initl) :: restil -> + (* Create a separate subobject iterator *) + let so' = makeSubobj so.host so.soTyp so.soOff in + (* Go inside the comp *) + so'.stack <- [InComp(so'.curOff, comp, fieldsToInit comp None)]; + normalSubobj so'; + let acc', initl' = doInit isconst setone so' acc initl in + if initl' <> [] then + ignore (warn "Too many initializers for structure"); + (* Advance past the structure *) + advanceSubobj so; + (* Continue *) + doInit isconst setone so acc' restil + + (* A scalar with a initializer surrounded by braces *) + | _, (A.NEXT_INIT, A.COMPOUND_INIT [(A.NEXT_INIT, + A.SINGLE_INIT oneinit)]) :: restil -> + let se, oneinit', t' = doExp isconst oneinit (AExp(Some so.soTyp)) in + setone so.soOff (mkCastT oneinit' t' so.soTyp); + (* Move on *) + advanceSubobj so; + doInit isconst setone so (acc @@ se) restil + + | t, (A.NEXT_INIT, _) :: _ -> + E.s (unimp "doInit: unexpected NEXT_INIT for %a\n" d_type t); + + (* We have a designator *) + | _, (what, ie) :: restil when what != A.NEXT_INIT -> + (* Process a designator and position to the designated subobject *) + let rec addressSubobj + (so: subobj) + (what: A.initwhat) + (acc: chunk) : chunk = + (* Always start from the current element *) + so.stack <- []; so.eof <- false; + normalSubobj so; + let rec address (what: A.initwhat) (acc: chunk) : chunk = + match what with + A.NEXT_INIT -> acc + | A.INFIELD_INIT (fn, whatnext) -> begin + match unrollType so.soTyp with + TComp (comp, _) -> + let toinit = fieldsToInit comp (Some fn) in + so.stack <- InComp(so.soOff, comp, toinit) :: so.stack; + normalSubobj so; + address whatnext acc + + | _ -> E.s (error "Field designator %s not in a struct " fn) + end + + | A.ATINDEX_INIT(idx, whatnext) -> begin + match unrollType so.soTyp with + TArray (bt, leno, _) -> + let ilen = integerArrayLength leno in + let nextidx', doidx = + let (doidx, idxe', _) = + doExp true idx (AExp(Some intType)) in + match constFold true idxe', isNotEmpty doidx with + Const(CInt64(x, _, _)), false -> Int64.to_int x, doidx + | _ -> E.s (error + "INDEX initialization designator is not a constant") + in + if nextidx' < 0 || nextidx' >= ilen then + E.s (error "INDEX designator is outside bounds"); + so.stack <- + InArray(so.soOff, bt, ilen, ref nextidx') :: so.stack; + normalSubobj so; + address whatnext (acc @@ doidx) + + | _ -> E.s (error "INDEX designator for a non-array") + end + + | A.ATINDEXRANGE_INIT _ -> + E.s (bug "addressSubobj: INDEXRANGE") + in + address what acc + in + (* First expand the INDEXRANGE by making copies *) + let rec expandRange (top: A.initwhat -> A.initwhat) = function + | A.INFIELD_INIT (fn, whatnext) -> + expandRange (fun what -> top (A.INFIELD_INIT(fn, what))) whatnext + | A.ATINDEX_INIT (idx, whatnext) -> + expandRange (fun what -> top (A.ATINDEX_INIT(idx, what))) whatnext + + | A.ATINDEXRANGE_INIT (idxs, idxe) -> + let (doidxs, idxs', _) = + doExp true idxs (AExp(Some intType)) in + let (doidxe, idxe', _) = + doExp true idxe (AExp(Some intType)) in + if isNotEmpty doidxs || isNotEmpty doidxe then + E.s (error "Range designators are not constants\n"); + let first, last = + match constFold true idxs', constFold true idxe' with + Const(CInt64(s, _, _)), + Const(CInt64(e, _, _)) -> + Int64.to_int s, Int64.to_int e + | _ -> E.s (error + "INDEX_RANGE initialization designator is not a constant") + in + if first < 0 || first > last then + E.s (error + "start index larger than end index in range initializer"); + let rec loop (i: int) = + if i > last then restil + else + (top (A.ATINDEX_INIT(A.CONSTANT(A.CONST_INT(string_of_int i)), + A.NEXT_INIT)), ie) + :: loop (i + 1) + in + doInit isconst setone so acc (loop first) + + | A.NEXT_INIT -> (* We have not found any RANGE *) + let acc' = addressSubobj so what acc in + doInit isconst setone so (acc @@ acc') + ((A.NEXT_INIT, ie) :: restil) + in + expandRange (fun x -> x) what + + | t, (what, ie) :: _ -> + E.s (bug "doInit: cases for t=%a" d_type t) + + +(* Create and add to the file (if not already added) a global. Return the + * varinfo *) +and createGlobal (specs : (typ * storage * bool * A.attribute list)) + (((n,ndt,a,cloc), inite) : A.init_name) : varinfo = + try + if debugGlobal then + ignore (E.log "createGlobal: %s\n" n); + (* Make a first version of the varinfo *) + let vi = makeVarInfoCabs ~isformal:false + ~isglobal:true (convLoc cloc) specs (n,ndt,a) in + (* Add the variable to the environment before doing the initializer + * because it might refer to the variable itself *) + if isFunctionType vi.vtype then begin + if inite != A.NO_INIT then + E.s (error "Function declaration with initializer (%s)\n" + vi.vname); + (* sm: if it's a function prototype, and the storage class *) + (* isn't specified, make it 'extern'; this fixes a problem *) + (* with no-storage prototype and static definition *) + if vi.vstorage = NoStorage then + (*(trace "sm" (dprintf "adding extern to prototype of %s\n" n));*) + vi.vstorage <- Extern; + end; + let vi, alreadyInEnv = makeGlobalVarinfo (inite != A.NO_INIT) vi in +(* + ignore (E.log "createGlobal %a: %s type=%a\n" + d_loc (convLoc cloc) vi.vname d_plaintype vi.vtype); +*) + (* Do the initializer and complete the array type if necessary *) + let init : init option = + if inite = A.NO_INIT then + None + else + let se, ie', et = doInitializer vi inite in + (* Maybe we now have a better type *) + vi.vtype <- et; + if isNotEmpty se then + E.s (error "global initializer"); + Some ie' + in + + try + let oldloc = H.find alreadyDefined vi.vname in + if init != None then begin + E.s (error "Global %s was already defined at %a\n" + vi.vname d_loc oldloc); + end; + if debugGlobal then + ignore (E.log " global %s was already defined\n" vi.vname); + (* Do not declare it again *) + vi + with Not_found -> begin + (* Not already defined *) + if debugGlobal then + ignore (E.log " first definition for %s\n" vi.vname); + if init != None then begin + (* weimer: Sat Dec 8 17:43:34 2001 + * MSVC NT Kernel headers include this lovely line: + * extern const GUID __declspec(selectany) \ + * MOUNTDEV_MOUNTED_DEVICE_GUID = { 0x53f5630d, 0xb6bf, 0x11d0, { \ + * 0x94, 0xf2, 0x00, 0xa0, 0xc9, 0x1e, 0xfb, 0x8b } }; + * So we allow "extern" + "initializer" if "const" is + * around. *) + (* sm: As I read the ISO spec, in particular 6.9.2 and 6.7.8, + * "extern int foo = 3" is exactly equivalent to "int foo = 3"; + * that is, if you put an initializer, then it is a definition, + * and "extern" is redundantly giving the name external linkage. + * gcc emits a warning, I guess because it is contrary to + * usual practice, but I think CIL warnings should be about + * semantic rather than stylistic issues, so I see no reason to + * even emit a warning. *) + if vi.vstorage = Extern then + vi.vstorage <- NoStorage; (* equivalent and canonical *) + + H.add alreadyDefined vi.vname !currentLoc; + IH.remove mustTurnIntoDef vi.vid; + cabsPushGlobal (GVar(vi, {init = init}, !currentLoc)); + vi + end else begin + if not (isFunctionType vi.vtype) + && not (IH.mem mustTurnIntoDef vi.vid) then + begin + IH.add mustTurnIntoDef vi.vid true + end; + if not alreadyInEnv then begin (* Only one declaration *) + (* If it has function type it is a prototype *) + cabsPushGlobal (GVarDecl (vi, !currentLoc)); + vi + end else begin + if debugGlobal then + ignore (E.log " already in env %s\n" vi.vname); + vi + end + end + end + with e -> begin + ignore (E.log "error in createGlobal(%s: %a): %s\n" n + d_loc !currentLoc + (Printexc.to_string e)); + cabsPushGlobal (dGlobal (dprintf "booo - error in global %s (%t)" + n d_thisloc) !currentLoc); + dummyFunDec.svar + end +(* + ignore (E.log "Env after processing global %s is:@!%t@!" + n docEnv); + ignore (E.log "Alpha after processing global %s is:@!%t@!" + n docAlphaTable) +*) + +(* Must catch the Static local variables. Make them global *) +and createLocal ((_, sto, _, _) as specs) + ((((n, ndt, a, cloc) : A.name), + (inite: A.init_expression)) as init_name) + : chunk = + let loc = convLoc cloc in + (* Check if we are declaring a function *) + let rec isProto (dt: decl_type) : bool = + match dt with + | PROTO (JUSTBASE, _, _) -> true + | PROTO (x, _, _) -> isProto x + | PARENTYPE (_, x, _) -> isProto x + | ARRAY (x, _, _) -> isProto x + | PTR (_, x) -> isProto x + | _ -> false + in + match ndt with + (* Maybe we have a function prototype in local scope. Make it global. We + * do this even if the storage is Static *) + | _ when isProto ndt -> + let vi = createGlobal specs init_name in + (* Add it to the environment to shadow previous decls *) + addLocalToEnv n (EnvVar vi); + empty + + | _ when sto = Static -> + if debugGlobal then + ignore (E.log "createGlobal (local static): %s\n" n); + + + (* Now alpha convert it to make sure that it does not conflict with + * existing globals or locals from this function. *) + let newname, _ = newAlphaName true "" n in + (* Make it global *) + let vi = makeVarInfoCabs ~isformal:false + ~isglobal:true + loc specs (newname, ndt, a) in + (* However, we have a problem if a real global appears later with the + * name that we have happened to choose for this one. Remember these names + * for later. *) + H.add staticLocals vi.vname vi; + (* Add it to the environment as a local so that the name goes out of + * scope properly *) + addLocalToEnv n (EnvVar vi); + + (* Maybe this is an array whose length depends on something with local + scope, e.g. "static char device[ sizeof(local) ]". + Const-fold the type to fix this. *) + vi.vtype <- constFoldType vi.vtype; + + let init : init option = + if inite = A.NO_INIT then + None + else begin + let se, ie', et = doInitializer vi inite in + (* Maybe we now have a better type *) + vi.vtype <- et; + if isNotEmpty se then + E.s (error "global static initializer"); + (* Maybe the initializer refers to the function itself. + Push a prototype for the function, just in case. Hopefully, + if does not refer to the locals *) + cabsPushGlobal (GVarDecl (!currentFunctionFDEC.svar, !currentLoc)); + Some ie' + end + in + cabsPushGlobal (GVar(vi, {init = init}, !currentLoc)); + empty + + (* Maybe we have an extern declaration. Make it a global *) + | _ when sto = Extern -> + let vi = createGlobal specs init_name in + (* Add it to the local environment to ensure that it shadows previous + * local variables *) + addLocalToEnv n (EnvVar vi); + empty + + | _ -> + (* Make a variable of potentially variable size. If se0 <> empty then + * it is a variable size variable *) + let vi,se0,len,isvarsize = + makeVarSizeVarInfo loc specs (n, ndt, a) in + + let vi = alphaConvertVarAndAddToEnv true vi in (* Replace vi *) + let se1 = + if isvarsize then begin (* Variable-sized array *) + ignore (warn "Variable-sized local variable %s" vi.vname); + (* Make a local variable to keep the length *) + let savelen = + makeVarInfoCabs + ~isformal:false + ~isglobal:false + loc + (TInt(IUInt, []), NoStorage, false, []) + ("__lengthof" ^ vi.vname,JUSTBASE, []) + in + (* Register it *) + let savelen = alphaConvertVarAndAddToEnv true savelen in + (* Compute the sizeof *) + let sizeof = + BinOp(Mult, + SizeOfE (Lval(Mem(Lval(var vi)), NoOffset)), + Lval (var savelen), !typeOfSizeOf) in + (* Register the length *) + IH.add varSizeArrays vi.vid sizeof; + (* There can be no initializer for this *) + if inite != A.NO_INIT then + E.s (error "Variable-sized array cannot have initializer"); + se0 +++ (Set(var savelen, len, !currentLoc)) + (* Initialize the variable *) + +++ (Call(Some(var vi), Lval(var (allocaFun ())), + [ sizeof ], !currentLoc)) + end else empty + in + if inite = A.NO_INIT then + se1 (* skipChunk *) + else begin + let se4, ie', et = doInitializer vi inite in + (* Fix the length *) + (match vi.vtype, ie', et with + (* We have a length now *) + TArray(_,None, _), _, TArray(_, Some _, _) -> vi.vtype <- et + (* Initializing a local array *) + | TArray(TInt((IChar|IUChar|ISChar), _) as bt, None, a), + SingleInit(Const(CStr s)), _ -> + vi.vtype <- TArray(bt, + Some (integer (String.length s + 1)), + a) + | _, _, _ -> ()); + + (* Now create assignments instead of the initialization *) + se1 @@ se4 @@ (assignInit (Var vi, NoOffset) ie' et empty) + end + +and doAliasFun vtype (thisname:string) (othername:string) + (sname:single_name) (loc: cabsloc) : unit = + (* This prototype declares that name is an alias for + othername, which must be defined in this file *) +(* E.log "%s is alias for %s at %a\n" thisname othername *) +(* d_loc !currentLoc; *) + let rt, formals, isva, _ = splitFunctionType vtype in + if isva then E.s (error "%a: alias unsupported with varargs." + d_loc !currentLoc); + let args = List.map + (fun (n,_,_) -> A.VARIABLE n) + (argsToList formals) in + let call = A.CALL (A.VARIABLE othername, args) in + let stmt = if isVoidType rt then A.COMPUTATION(call, loc) + else A.RETURN(call, loc) + in + let body = { A.blabels = []; A.battrs = []; A.bstmts = [stmt] } in + let fdef = A.FUNDEF (sname, body, loc, loc) in + ignore (doDecl true fdef); + (* get the new function *) + let v,_ = try lookupGlobalVar thisname + with Not_found -> E.s (bug "error in doDecl") in + v.vattr <- dropAttribute "alias" v.vattr + + +(* Do one declaration *) +and doDecl (isglobal: bool) : A.definition -> chunk = function + | A.DECDEF ((s, nl), loc) -> + currentLoc := convLoc(loc); + (* Do the specifiers exactly once *) + let sugg = + match nl with + [] -> "" + | ((n, _, _, _), _) :: _ -> n + in + let spec_res = doSpecList sugg s in + (* Do all the variables and concatenate the resulting statements *) + let doOneDeclarator (acc: chunk) (name: init_name) = + let (n,ndt,a,l),_ = name in + if isglobal then begin + let bt,_,_,attrs = spec_res in + let vtype, nattr = + doType (AttrName false) bt (A.PARENTYPE(attrs, ndt, a)) in + (match filterAttributes "alias" nattr with + [] -> (* ordinary prototype. *) + ignore (createGlobal spec_res name) + (* E.log "%s is not aliased\n" name *) + | [Attr("alias", [AStr othername])] -> + if not (isFunctionType vtype) then begin + ignore (warn + "%a: CIL only supports attribute((alias)) for functions.\n" + d_loc !currentLoc); + ignore (createGlobal spec_res name) + end else + doAliasFun vtype n othername (s, (n,ndt,a,l)) loc + | _ -> E.s (error "Bad alias attribute at %a" d_loc !currentLoc)); + acc + end else + acc @@ createLocal spec_res name + in + let res = List.fold_left doOneDeclarator empty nl in +(* + ignore (E.log "after doDecl %a: res=%a\n" + d_loc !currentLoc d_chunk res); +*) + res + + + + | A.TYPEDEF (ng, loc) -> + currentLoc := convLoc(loc); + doTypedef ng; empty + + | A.ONLYTYPEDEF (s, loc) -> + currentLoc := convLoc(loc); + doOnlyTypedef s; empty + + | A.GLOBASM (s,loc) when isglobal -> + currentLoc := convLoc(loc); + cabsPushGlobal (GAsm (s, !currentLoc)); + empty + + | A.PRAGMA (a, loc) when isglobal -> begin + currentLoc := convLoc(loc); + match doAttr ("dummy", [a]) with + [Attr("dummy", [a'])] -> + let a'' = + match a' with + | ACons (s, args) -> Attr (s, args) + | _ -> E.s (error "Unexpected attribute in #pragma") + in + cabsPushGlobal (GPragma (a'', !currentLoc)); + empty + + | _ -> E.s (error "Too many attributes in pragma") + end + | A.TRANSFORMER (_, _, _) -> E.s (E.bug "TRANSFORMER in cabs2cil input") + | A.EXPRTRANSFORMER (_, _, _) -> + E.s (E.bug "EXPRTRANSFORMER in cabs2cil input") + + (* If there are multiple definitions of extern inline, turn all but the + * first into a prototype *) + | A.FUNDEF (((specs,(n,dt,a,loc')) : A.single_name), + (body : A.block), loc, _) + when isglobal && isExtern specs && isInline specs + && (H.mem genv (n ^ "__extinline")) -> + currentLoc := convLoc(loc); + let othervi, _ = lookupVar (n ^ "__extinline") in + if othervi.vname = n then + (* The previous entry in the env is also an extern inline version + of n. *) + ignore (warn "Duplicate extern inline definition for %s ignored" n) + else begin + (* Otherwise, the previous entry is an ordinary function that + happens to be named __extinline. Renaming n to n__extinline + would confict with other, so report an error. *) + E.s (unimp("Trying to rename %s to\n %s__extinline, but %s__extinline" + ^^ " already exists in the env.\n \"__extinline\" is" + ^^ " reserved for CIL.\n") n n n) + end; + (* Treat it as a prototype *) + doDecl isglobal (A.DECDEF ((specs, [((n,dt,a,loc'), A.NO_INIT)]), loc)) + + | A.FUNDEF (((specs,(n,dt,a, _)) : A.single_name), + (body : A.block), loc1, loc2) when isglobal -> + begin + let funloc = convLoc loc1 in + let endloc = convLoc loc2 in +(* ignore (E.log "Definition of %s at %a\n" n d_loc funloc); *) + currentLoc := funloc; + E.withContext + (fun _ -> dprintf "2cil: %s" n) + (fun _ -> + try + IH.clear callTempVars; + + (* Make the fundec right away, and we'll populate it later. We + * need this throughout the code to create temporaries. *) + currentFunctionFDEC := + { svar = makeGlobalVar "@tempname@" voidType; + slocals = []; (* For now we'll put here both the locals and + * the formals. Then "endFunction" will + * separate them *) + sformals = []; (* Not final yet *) + smaxid = 0; + sbody = dummyFunDec.sbody; (* Not final yet *) + smaxstmtid = None; + sallstmts = []; + }; + !currentFunctionFDEC.svar.vdecl <- funloc; + + constrExprId := 0; + (* Setup the environment. Add the formals to the locals. Maybe + * they need alpha-conv *) + enterScope (); (* Start the scope *) + + IH.clear varSizeArrays; + + (* Do not process transparent unions in function definitions. + * We'll do it later *) + transparentUnionArgs := []; + + (* Fix the NAME and the STORAGE *) + let _ = + let bt,sto,inl,attrs = doSpecList n specs in + !currentFunctionFDEC.svar.vinline <- inl; + + let ftyp, funattr = + doType (AttrName false) bt (A.PARENTYPE(attrs, dt, a)) in + !currentFunctionFDEC.svar.vtype <- ftyp; + !currentFunctionFDEC.svar.vattr <- funattr; + + (* If this is the definition of an extern inline then we change + * its name, by adding the suffix __extinline. We also make it + * static *) + let n', sto' = + let n' = n ^ "__extinline" in + if inl && sto = Extern then + n', Static + else begin + (* Maybe this is the body of a previous extern inline. Then + * we must take that one out of the environment because it + * is not used from here on. This will also ensure that + * then we make this functions' varinfo we will not think + * it is a duplicate definition *) + (try + ignore (lookupVar n'); (* if this succeeds, n' is defined*) + let oldvi, _ = lookupVar n in + if oldvi.vname = n' then begin + (* oldvi is an extern inline function that has been + renamed to n ^ "__extinline". Remove it from the + environment. *) + H.remove env n; H.remove genv n; + H.remove env n'; H.remove genv n' + end + else + (* oldvi is not a renamed extern inline function, and + we should do nothing. The reason the lookup + of n' succeeded is probably because there's + an ordinary function that happens to be named, + n ^ "__extinline", probably as a result of a previous + pass through CIL. See small2/extinline.c*) + () + with Not_found -> ()); + n, sto + end + in + (* Now we have the name and the storage *) + !currentFunctionFDEC.svar.vname <- n'; + !currentFunctionFDEC.svar.vstorage <- sto' + in + + (* Add the function itself to the environment. Add it before + * you do the body because the function might be recursive. Add + * it also before you add the formals to the environment + * because there might be a formal with the same name as the + * function and we want it to take precedence. *) + (* Make a variable out of it and put it in the environment *) + !currentFunctionFDEC.svar <- + fst (makeGlobalVarinfo true !currentFunctionFDEC.svar); + + (* If it is extern inline then we add it to the global + * environment for the original name as well. This will ensure + * that all uses of this function will refer to the renamed + * function *) + addGlobalToEnv n (EnvVar !currentFunctionFDEC.svar); + + if H.mem alreadyDefined !currentFunctionFDEC.svar.vname then + E.s (error "There is a definition already for %s" n); + +(* + ignore (E.log "makefunvar:%s@! type=%a@! vattr=%a@!" + n d_type thisFunctionVI.vtype + d_attrlist thisFunctionVI.vattr); +*) + + (* makeGlobalVarinfo might have changed the type of the function + * (when combining it with the type of the prototype). So get the + * type only now. *) + + (**** Process the TYPE and the FORMALS ***) + let _ = + let (returnType, formals_t, isvararg, funta) = + splitFunctionTypeVI !currentFunctionFDEC.svar + in + (* Record the returnType for doStatement *) + currentReturnType := returnType; + + + (* Create the formals and add them to the environment. *) + (* sfg: extract locations for the formals from dt *) + let doFormal (loc : location) (fn, ft, fa) = + let f = makeVarinfo false fn ft in + (f.vdecl <- loc; + f.vattr <- fa; + alphaConvertVarAndAddToEnv true f) + in + let rec doFormals fl' ll' = + begin + match (fl', ll') with + | [], _ -> [] + + | fl, [] -> (* no more locs available *) + List.map (doFormal !currentLoc) fl + + | f::fl, (_,(_,_,_,l))::ll -> + (* sfg: these lets seem to be necessary to + * force the right order of evaluation *) + let f' = doFormal (convLoc l) f in + let fl' = doFormals fl ll in + f' :: fl' + end + in + let fmlocs = (match dt with PROTO(_, fml, _) -> fml | _ -> []) in + let formals = doFormals (argsToList formals_t) fmlocs in + + (* Recreate the type based on the formals. *) + let ftype = TFun(returnType, + Some (List.map (fun f -> (f.vname, + f.vtype, + f.vattr)) formals), + isvararg, funta) in + (* + ignore (E.log "Funtype of %s: %a\n" n' d_type ftype); + *) + (* Now fix the names of the formals in the type of the function + * as well *) + !currentFunctionFDEC.svar.vtype <- ftype; + !currentFunctionFDEC.sformals <- formals; + in + (* Now change the type of transparent union args back to what it + * was so that the body type checks. We must do it this late + * because makeGlobalVarinfo from above might choke if we give + * the function a type containing transparent unions *) + let _ = + let rec fixbackFormals (idx: int) (args: varinfo list) : unit= + match args with + [] -> () + | a :: args' -> + (* Fix the type back to a transparent union type *) + (try + let origtype = List.assq idx !transparentUnionArgs in + a.vtype <- origtype; + with Not_found -> ()); + fixbackFormals (idx + 1) args' + in + fixbackFormals 0 !currentFunctionFDEC.sformals; + transparentUnionArgs := []; + in + + (********** Now do the BODY *************) + let _ = + let stmts = doBody body in + (* Finish everything *) + exitScope (); + + (* Now fill in the computed goto statement with cases. Do this + * before mkFunctionbody which resolves the gotos *) + (match !gotoTargetData with + Some (switchv, switch) -> + let switche, l = + match switch.skind with + Switch (switche, _, _, l) -> switche, l + | _ -> E.s(bug "the computed goto statement not a switch") + in + (* Build a default chunk that segfaults *) + let default = + defaultChunk + l + (i2c (Set ((Mem (mkCast (integer 0) intPtrType), + NoOffset), + integer 0, l))) + in + let bodychunk = ref default in + H.iter (fun lname laddr -> + bodychunk := + caseRangeChunk + [integer laddr] l + (gotoChunk lname l @@ !bodychunk)) + gotoTargetHash; + (* Now recreate the switch *) + let newswitch = switchChunk switche !bodychunk l in + (* We must still share the old switch statement since we + * have already inserted the goto's *) + let newswitchkind = + match newswitch.stmts with + [ s] + when newswitch.postins == [] && newswitch.cases == []-> + s.skind + | _ -> E.s (bug "Unexpected result from switchChunk") + in + switch.skind <- newswitchkind + + | None -> ()); + (* Now finish the body and store it *) + !currentFunctionFDEC.sbody <- mkFunctionBody stmts; + (* Reset the global parameters *) + gotoTargetData := None; + H.clear gotoTargetHash; + gotoTargetNextAddr := 0; + in + + + +(* + ignore (E.log "endFunction %s at %t:@! sformals=%a@! slocals=%a@!" + !currentFunctionFDEC.svar.vname d_thisloc + (docList ~sep:(chr ',') (fun v -> text v.vname)) + !currentFunctionFDEC.sformals + (docList ~sep:(chr ',') (fun v -> text v.vname)) + !currentFunctionFDEC.slocals); +*) + + let rec dropFormals formals locals = + match formals, locals with + [], l -> l + | f :: formals, l :: locals -> + if f != l then + E.s (bug "formal %s is not in locals (found instead %s)" + f.vname l.vname); + dropFormals formals locals + | _ -> E.s (bug "Too few locals") + in + !currentFunctionFDEC.slocals + <- dropFormals !currentFunctionFDEC.sformals + (List.rev !currentFunctionFDEC.slocals); + setMaxId !currentFunctionFDEC; + + (* Now go over the types of the formals and pull out the formals + * with transparent union type. Replace them with some shadow + * parameters and then add assignments *) + let _ = + let newformals, newbody = + List.fold_right (* So that the formals come out in order *) + (fun f (accform, accbody) -> + match isTransparentUnion f.vtype with + None -> (f :: accform, accbody) + | Some fstfield -> + (* A new shadow to be placed in the formals. Use + * makeTempVar to update smaxid and all others. *) + let shadow = + makeTempVar !currentFunctionFDEC fstfield.ftype in + (* Now take it out of the locals and replace it with + * the current formal. It is not worth optimizing this + * one. *) + !currentFunctionFDEC.slocals <- + f :: + (List.filter (fun x -> x.vid <> shadow.vid) + !currentFunctionFDEC.slocals); + (shadow :: accform, + mkStmt (Instr [Set ((Var f, Field(fstfield, + NoOffset)), + Lval (var shadow), + !currentLoc)]) :: accbody)) + !currentFunctionFDEC.sformals + ([], !currentFunctionFDEC.sbody.bstmts) + in + !currentFunctionFDEC.sbody.bstmts <- newbody; + (* To make sure sharing with the type is proper *) + setFormals !currentFunctionFDEC newformals; + in + + (* Now see whether we can fall through to the end of the function + * *) + (* weimer: Sat Dec 8 17:30:47 2001 MSVC NT kernel headers include + * functions like long convert(x) { __asm { mov eax, x \n cdq } } + * That set a return value via an ASM statement. As a result, I + * am changing this so a final ASM statement does not count as + * "fall through" for the purposes of this warning. *) + (* matth: But it's better to assume assembly will fall through, + * since most such blocks do. It's probably better to print an + * unnecessary warning than to break CIL's invariant that + * return statements are inserted properly. *) + let instrFallsThrough (i : instr) = match i with + Set _ -> true + | Call (None, Lval (Var e, NoOffset), _, _) -> + (* See if this is exit, or if it has the noreturn attribute *) + if e.vname = "exit" then false + else if hasAttribute "noreturn" e.vattr then false + else true + | Call _ -> true + | Asm _ -> true + in + let rec stmtFallsThrough (s: stmt) : bool = + match s.skind with + Instr(il) -> + List.fold_left (fun acc elt -> + acc && instrFallsThrough elt) true il + | Return _ | Break _ | Continue _ -> false + | Goto _ -> false + | If (_, b1, b2, _) -> + blockFallsThrough b1 || blockFallsThrough b2 + | Switch (e, b, targets, _) -> + (* See if there is a "default" case *) + if not + (List.exists (fun s -> + List.exists (function Default _ -> true | _ -> false) + s.labels) + targets) then begin +(* + ignore (E.log "Switch falls through because no default"); + +*) true (* We fall through because there is no default *) + end else begin + (* We must examine all cases. If any falls through, + * then the switch falls through. *) + blockFallsThrough b || blockCanBreak b + end +(* + | Loop (b, _, _, _) -> + (* A loop falls through if it can break. *) + blockCanBreak b +*) + | While (_, b, _) -> blockCanBreak b + | DoWhile (_, b, _) -> blockCanBreak b + | For (_, _, _, b, _) -> blockCanBreak b + | Block b -> blockFallsThrough b + | TryFinally (b, h, _) -> blockFallsThrough h + | TryExcept (b, _, h, _) -> true (* Conservative *) + and blockFallsThrough b = + let rec fall = function + [] -> true + | s :: rest -> + if stmtFallsThrough s then begin +(* + ignore (E.log "Stmt %a falls through\n" d_stmt s); +*) + fall rest + end else begin +(* + ignore (E.log "Stmt %a DOES NOT fall through\n" + d_stmt s); +*) + (* If we are not falling thorough then maybe there + * are labels who are *) + labels rest + end + and labels = function + [] -> false + (* We have a label, perhaps we can jump here *) + | s :: rest when s.labels <> [] -> +(* + ignore (E.log "invoking fall %a: %a\n" + d_loc !currentLoc d_stmt s); +*) + fall (s :: rest) + | _ :: rest -> labels rest + in + let res = fall b.bstmts in +(* + ignore (E.log "blockFallsThrough=%b %a\n" res d_block b); +*) + res + (* will we leave this statement or block with a break command? *) + and stmtCanBreak (s: stmt) : bool = + match s.skind with + Instr _ | Return _ | Continue _ | Goto _ -> false + | Break _ -> true + | If (_, b1, b2, _) -> + blockCanBreak b1 || blockCanBreak b2 + | Switch _ | (*Loop _*) While _ | DoWhile _ | For _ -> + (* switches and loops catch any breaks in their bodies *) + false + | Block b -> blockCanBreak b + | TryFinally (b, h, _) -> blockCanBreak b || blockCanBreak h + | TryExcept (b, _, h, _) -> blockCanBreak b || blockCanBreak h + and blockCanBreak b = + List.exists stmtCanBreak b.bstmts + in + if blockFallsThrough !currentFunctionFDEC.sbody then begin +(* + let retval = + match unrollType !currentReturnType with + TVoid _ -> None + | (TInt _ | TEnum _ | TFloat _ | TPtr _) as rt -> + ignore (warn "Body of function %s falls-through. Adding a return statement\n" !currentFunctionFDEC.svar.vname); + Some (mkCastT zero intType rt) + | _ -> + ignore (warn "Body of function %s falls-through and cannot find an appropriate return value\n" !currentFunctionFDEC.svar.vname); + None + in + if not (hasAttribute "noreturn" + !currentFunctionFDEC.svar.vattr) then + !currentFunctionFDEC.sbody.bstmts <- + !currentFunctionFDEC.sbody.bstmts + @ [mkStmt (Return(retval, endloc))] +*) + end; + + (* ignore (E.log "The env after finishing the body of %s:\n%t\n" + n docEnv); *) + cabsPushGlobal (GFun (!currentFunctionFDEC, funloc)); + empty + with E.Error as e -> raise e + | e -> begin + ignore (E.log "error in collectFunction %s: %s\n" + n (Printexc.to_string e)); + cabsPushGlobal (GAsm("error in function " ^ n, !currentLoc)); + empty + end) + () (* argument of E.withContext *) + end (* FUNDEF *) + + | LINKAGE (n, loc, dl) -> + currentLoc := convLoc loc; + if n <> "C" then + ignore (warn "Encountered linkage specification \"%s\"" n); + if not isglobal then + E.s (error "Encountered linkage specification in local scope"); + (* For now drop the linkage on the floor !!! *) + List.iter + (fun d -> + let s = doDecl isglobal d in + if isNotEmpty s then + E.s (bug "doDecl returns non-empty statement for global")) + dl; + empty + + | _ -> E.s (error "unexpected form of declaration") + +and doTypedef ((specs, nl): A.name_group) = + try + (* Do the specifiers exactly once *) + let bt, sto, inl, attrs = doSpecList (suggestAnonName nl) specs in + if sto <> NoStorage || inl then + E.s (error "Storage or inline specifier not allowed in typedef"); + let createTypedef ((n,ndt,a,loc) : A.name) = + (* E.s (error "doTypeDef") *) + try + let newTyp, tattr = + doType AttrType bt (A.PARENTYPE(attrs, ndt, a)) in + let newTyp' = cabsTypeAddAttributes tattr newTyp in + (* Create a new name for the type. Use the same name space as that of + * variables to avoid confusion between variable names and types. This + * is actually necessary in some cases. *) + let n', _ = newAlphaName true "" n in + let ti = { tname = n'; ttype = newTyp'; treferenced = false } in + (* Since we use the same name space, we might later hit a global with + * the same name and we would want to change the name of the global. + * It is better to change the name of the type instead. So, remember + * all types whose names have changed *) + H.add typedefs n' ti; + let namedTyp = TNamed(ti, []) in + (* Register the type. register it as local because we might be in a + * local context *) + addLocalToEnv (kindPlusName "type" n) (EnvTyp namedTyp); + cabsPushGlobal (GType (ti, !currentLoc)) + with E.Error as e -> raise e + | e -> begin + ignore (E.log "Error on A.TYPEDEF (%s)\n" + (Printexc.to_string e)); + cabsPushGlobal (GAsm ("booo_typedef:" ^ n, !currentLoc)) + end + in + List.iter createTypedef nl + with E.Error as e -> raise e + | e -> begin + ignore (E.log "Error on A.TYPEDEF (%s)\n" + (Printexc.to_string e)); + let fstname = + match nl with + [] -> "" + | (n, _, _, _) :: _ -> n + in + cabsPushGlobal (GAsm ("booo_typedef: " ^ fstname, !currentLoc)) + end + +and doOnlyTypedef (specs: A.spec_elem list) : unit = + try + let bt, sto, inl, attrs = doSpecList "" specs in + if sto <> NoStorage || inl then + E.s (error "Storage or inline specifier not allowed in typedef"); + let restyp, nattr = doType AttrType bt (A.PARENTYPE(attrs, + A.JUSTBASE, [])) in + if nattr <> [] then + ignore (warn "Ignoring identifier attribute"); + (* doSpec will register the type. *) + (* See if we are defining a composite or enumeration type, and in that + * case move the attributes from the defined type into the composite type + * *) + let isadef = + List.exists + (function + A.SpecType(A.Tstruct(_, Some _, _)) -> true + | A.SpecType(A.Tunion(_, Some _, _)) -> true + | A.SpecType(A.Tenum(_, Some _, _)) -> true + | _ -> false) specs + in + match restyp with + TComp(ci, al) -> + if isadef then begin + ci.cattr <- cabsAddAttributes ci.cattr al; + (* The GCompTag was already added *) + end else (* Add a GCompTagDecl *) + cabsPushGlobal (GCompTagDecl(ci, !currentLoc)) + | TEnum(ei, al) -> + if isadef then begin + ei.eattr <- cabsAddAttributes ei.eattr al; + end else + cabsPushGlobal (GEnumTagDecl(ei, !currentLoc)) + | _ -> + ignore (warn "Ignoring un-named typedef that does not introduce a struct or enumeration type\n") + + with E.Error as e -> raise e + | e -> begin + ignore (E.log "Error on A.ONLYTYPEDEF (%s)\n" + (Printexc.to_string e)); + cabsPushGlobal (GAsm ("booo_typedef", !currentLoc)) + end + +and assignInit (lv: lval) + (ie: init) + (iet: typ) + (acc: chunk) : chunk = + match ie with + SingleInit e -> + let (_, e'') = castTo iet (typeOfLval lv) e in + acc +++ (Set(lv, e'', !currentLoc)) + | CompoundInit (t, initl) -> + foldLeftCompound + ~doinit:(fun off i it acc -> + assignInit (addOffsetLval off lv) i it acc) + ~ct:t + ~initl:initl + ~acc:acc +(* + | ArrayInit (bt, len, initl) -> + let idx = ref ( -1 ) in + List.fold_left + (fun acc i -> + assignInit (addOffsetLval (Index(integer !idx, NoOffset)) lv) i bt acc) + acc + initl +*) + (* Now define the processors for body and statement *) +and doBody (blk: A.block) : chunk = + enterScope (); + (* Rename the labels and add them to the environment *) + List.iter (fun l -> ignore (genNewLocalLabel l)) blk.blabels; + (* See if we have some attributes *) + let battrs = doAttributes blk.A.battrs in + + let bodychunk = + afterConversion + (List.fold_left (* !!! @ evaluates its arguments backwards *) + (fun prev s -> let res = doStatement s in + prev @@ res) + empty + blk.A.bstmts) + in + exitScope (); + + + if battrs == [] then + bodychunk + else begin + let b = c2block bodychunk in + b.battrs <- battrs; + s2c (mkStmt (Block b)) + end + +and doStatement (s : A.statement) : chunk = + try + match s with + A.NOP _ -> skipChunk + | A.COMPUTATION (e, loc) -> + currentLoc := convLoc loc; + let (lasts, data) = !gnu_body_result in + if lasts == s then begin (* This is the last in a GNU_BODY *) + let (s', e', t') = doExp false e (AExp None) in + data := Some (e', t'); (* Record the result *) + s' + end else + let (s', _, _) = doExp false e ADrop in + (* drop the side-effect free expression *) + (* And now do some peep-hole optimizations *) + s' + + | A.BLOCK (b, loc) -> + currentLoc := convLoc loc; + doBody b + + | A.SEQUENCE (s1, s2, loc) -> + (doStatement s1) @@ (doStatement s2) + + | A.IF(e,st,sf,loc) -> + let st' = doStatement st in + let sf' = doStatement sf in + currentLoc := convLoc loc; + doCondition false e st' sf' + + | A.WHILE(e,s,loc) -> +(* + startLoop true; + let s' = doStatement s in + exitLoop (); + let loc' = convLoc loc in + currentLoc := loc'; + loopChunk ((doCondition false e skipChunk + (breakChunk loc')) + @@ s') +*) + (** We need to convert A.WHILE(e,s) where e may have side effects + into Cil.While(e',s') where e' is side-effect free. *) + + (* Let e == (sCond , eCond) with sCond a sequence of statements + and eCond a side-effect free expression. *) + let (sCond, eCond, _) = doExp false e (AExp None) in + + (* Then doStatement(A.WHILE((sCond , eCond), s)) + = sCond ; Cil.While(eCond, (doStatement(s) ; sCond)) + where doStatement(A.CONTINUE) = (sCond ; Cil.Continue). *) + + startLoop (DuplicateBeforeContinue sCond); + let s' = doStatement s in + exitLoop (); + let loc' = convLoc loc in + currentLoc := loc'; + sCond @@ (whileChunk eCond (s' @@ sCond)) + + | A.DOWHILE(e,s,loc) -> +(* + startLoop false; + let s' = doStatement s in + let loc' = convLoc loc in + currentLoc := loc'; + let s'' = + consLabContinue (doCondition false e skipChunk (breakChunk loc')) + in + exitLoop (); + loopChunk (s' @@ s'') +*) + (** We need to convert A.DOWHILE(e,s) where e may have side effects + into Cil.DoWhile(e',s') where e' is side-effect free. *) + + (* Let e == (sCond , eCond) with sCond a sequence of statements + and eCond a side-effect free expression. *) + let (sCond, eCond, _) = doExp false e (AExp None) in + + (* Then doStatement(A.DOWHILE((sCond , eCond), s)) + = Cil.DoWhile(eCond, (doStatement(s) ; sCond)) + where doStatement(A.CONTINUE) = (sCond ; Cil.Continue). *) + + startLoop (DuplicateBeforeContinue sCond); + let s' = doStatement s in + exitLoop (); + let loc' = convLoc loc in + currentLoc := loc'; + doWhileChunk eCond (s' @@ sCond) + + | A.FOR(fc1,e2,e3,s,loc) -> +(*begin + let loc' = convLoc loc in + currentLoc := loc'; + enterScope (); (* Just in case we have a declaration *) + let (se1, _, _) = + match fc1 with + FC_EXP e1 -> doExp false e1 ADrop + | FC_DECL d1 -> (doDecl false d1, zero, voidType) + in + let (se3, _, _) = doExp false e3 ADrop in + startLoop false; + let s' = doStatement s in + currentLoc := loc'; + let s'' = consLabContinue se3 in + exitLoop (); + let res = + match e2 with + A.NOTHING -> (* This means true *) + se1 @@ loopChunk (s' @@ s'') + | _ -> + se1 @@ loopChunk ((doCondition false e2 skipChunk (breakChunk loc')) + @@ s' @@ s'') + in + exitScope (); + res + end +*) + (** We need to convert A.FOR(e1,e2,e3,s) where e1, e2 and e3 may + have side effects into Cil.For(bInit,e2',bIter,s') where e2' + is side-effect free. **) + + (* Let e1 == bInit be a block of statements + Let e2 == (bCond , eCond) with bCond a block of statements + and eCond a side-effect free expression + Let e3 == bIter be a sequence of statements. *) + let (bInit, _, _) = match fc1 with + | FC_EXP e1 -> doExp false e1 ADrop + | FC_DECL d1 -> (doDecl false d1, zero, voidType) in + let (bCond, eCond, _) = doExp false e2 (AExp None) in + let eCond' = match eCond with + | Const(CStr "exp_nothing") -> Cil.one + | _ -> eCond in + let (bIter, _, _) = doExp false e3 ADrop in + + (* Then doStatement(A.FOR(bInit, (bCond , eCond), bIter, s)) + = Cil.For({bInit; bCond}, eCond', {bIter; bCond}, {doStatement(s)}) + where doStatement(A.CONTINUE) = Cil.Continue. *) + + startLoop ContinueUnchanged; + let s' = doStatement s in + exitLoop (); + let loc' = convLoc loc in + currentLoc := loc'; + (forChunk (bInit @@ bCond) eCond' (bIter @@ bCond) s') + + | A.BREAK loc -> + let loc' = convLoc loc in + currentLoc := loc'; + breakChunk loc' + + | A.CONTINUE loc -> + let loc' = convLoc loc in + currentLoc := loc'; +(* + continueOrLabelChunk loc' +*) + continueDuplicateChunk loc' + + | A.RETURN (A.NOTHING, loc) -> + let loc' = convLoc loc in + currentLoc := loc'; + if not (isVoidType !currentReturnType) then + ignore (warn "Return statement without a value in function returning %a\n" d_type !currentReturnType); + returnChunk None loc' + + | A.RETURN (e, loc) -> + let loc' = convLoc loc in + currentLoc := loc'; + (* Sometimes we return the result of a void function call *) + if isVoidType !currentReturnType then begin + ignore (warn "Return statement with a value in function returning void"); + let (se, _, _) = doExp false e ADrop in + se @@ returnChunk None loc' + end else begin + let (se, e', et) = + doExp false e (AExp (Some !currentReturnType)) in + let (et'', e'') = castTo et (!currentReturnType) e' in + se @@ (returnChunk (Some e'') loc') + end + + | A.SWITCH (e, s, loc) -> + let loc' = convLoc loc in + currentLoc := loc'; + let (se, e', et) = doExp false e (AExp (Some intType)) in + let (et'', e'') = castTo et intType e' in + let s' = doStatement s in + se @@ (switchChunk e'' s' loc') + + | A.CASE (e, s, loc) -> + let loc' = convLoc loc in + currentLoc := loc'; + let (se, e', et) = doExp true e (AExp None) in + if isNotEmpty se then + E.s (error "Case statement with a non-constant"); + caseRangeChunk [if !lowerConstants then constFold false e' else e'] + loc' (doStatement s) + + | A.CASERANGE (el, eh, s, loc) -> + let loc' = convLoc loc in + currentLoc := loc'; + let (sel, el', etl) = doExp false el (AExp None) in + let (seh, eh', etl) = doExp false eh (AExp None) in + if isNotEmpty sel || isNotEmpty seh then + E.s (error "Case statement with a non-constant"); + let il, ih = + match constFold true el', constFold true eh' with + Const(CInt64(il, _, _)), Const(CInt64(ih, _, _)) -> + Int64.to_int il, Int64.to_int ih + | _ -> E.s (unimp "Cannot understand the constants in case range") + in + if il > ih then + E.s (error "Empty case range"); + let rec mkAll (i: int) = + if i > ih then [] else integer i :: mkAll (i + 1) + in + caseRangeChunk (mkAll il) loc' (doStatement s) + + + | A.DEFAULT (s, loc) -> + let loc' = convLoc loc in + currentLoc := loc'; + defaultChunk loc' (doStatement s) + + | A.LABEL (l, s, loc) -> + let loc' = convLoc loc in + currentLoc := loc'; + (* Lookup the label because it might have been locally defined *) + consLabel (lookupLabel l) (doStatement s) loc' true + + | A.GOTO (l, loc) -> + let loc' = convLoc loc in + currentLoc := loc'; + (* Maybe we need to rename this label *) + gotoChunk (lookupLabel l) loc' + + | A.COMPGOTO (e, loc) -> begin + let loc' = convLoc loc in + currentLoc := loc'; + (* Do the expression *) + let se, e', t' = doExp false e (AExp (Some voidPtrType)) in + match !gotoTargetData with + Some (switchv, switch) -> (* We have already generated this one *) + se + @@ i2c(Set (var switchv, mkCast e' uintType, loc')) + @@ s2c(mkStmt(Goto (ref switch, loc'))) + + | None -> begin + (* Make a temporary variable *) + let vchunk = createLocal + (TInt(IUInt, []), NoStorage, false, []) + (("__compgoto", A.JUSTBASE, [], loc), A.NO_INIT) + in + if not (isEmpty vchunk) then + E.s (unimp "Non-empty chunk in creating temporary for goto *"); + let switchv, _ = + try lookupVar "__compgoto" + with Not_found -> E.s (bug "Cannot find temporary for goto *"); + in + (* Make a switch statement. We'll fill in the statements at the + * end of the function *) + let switch = mkStmt (Switch (Lval(var switchv), + mkBlock [], [], loc')) in + (* And make a label for it since we'll goto it *) + switch.labels <- [Label ("__docompgoto", loc', false)]; + gotoTargetData := Some (switchv, switch); + se @@ i2c (Set(var switchv, mkCast e' uintType, loc')) @@ + s2c switch + end + end + + | A.DEFINITION d -> + let s = doDecl false d in +(* + ignore (E.log "Def at %a: %a\n" d_loc !currentLoc d_chunk s); +*) + s + + + + | A.ASM (asmattr, tmpls, details, loc) -> + (* Make sure all the outs are variables *) + let loc' = convLoc loc in + let attr' = doAttributes asmattr in + currentLoc := loc'; + let stmts : chunk ref = ref empty in + let (tmpls', outs', ins', clobs') = + match details with + | None -> + let tmpls' = + if !msvcMode then + tmpls + else + let pattern = Str.regexp "%" in + let escape = Str.global_replace pattern "%%" in + List.map escape tmpls + in + (tmpls', [], [], []) + | Some { aoutputs = outs; ainputs = ins; aclobbers = clobs } -> + let outs' = + List.map + (fun (c, e) -> + let (se, e', t) = doExp false e (AExp None) in + let lv = + match e' with + | Lval lval + | StartOf lval -> lval + | _ -> E.s (error "Expected lval for ASM outputs") + in + stmts := !stmts @@ se; + (c, lv)) outs + in + (* Get the side-effects out of expressions *) + let ins' = + List.map + (fun (c, e) -> + let (se, e', et) = doExp false e (AExp None) in + stmts := !stmts @@ se; + (c, e')) + ins + in + (tmpls, outs', ins', clobs) + in + !stmts @@ + (i2c (Asm(attr', tmpls', outs', ins', clobs', loc'))) + + | TRY_FINALLY (b, h, loc) -> + let loc' = convLoc loc in + currentLoc := loc'; + let b': chunk = doBody b in + let h': chunk = doBody h in + if b'.cases <> [] || h'.cases <> [] then + E.s (error "Try statements cannot contain switch cases"); + + s2c (mkStmt (TryFinally (c2block b', c2block h', loc'))) + + | TRY_EXCEPT (b, e, h, loc) -> + let loc' = convLoc loc in + currentLoc := loc'; + let b': chunk = doBody b in + (* Now do e *) + let ((se: chunk), e', t') = doExp false e (AExp None) in + let h': chunk = doBody h in + if b'.cases <> [] || h'.cases <> [] || se.cases <> [] then + E.s (error "Try statements cannot contain switch cases"); + (* Now take se and try to convert it to a list of instructions. This + * might not be always possible *) + let il' = + match compactStmts se.stmts with + [] -> se.postins + | [ s ] -> begin + match s.skind with + Instr il -> il @ se.postins + | _ -> E.s (error "Except expression contains unexpected statement") + end + | _ -> E.s (error "Except expression contains too many statements") + in + s2c (mkStmt (TryExcept (c2block b', (il', e'), c2block h', loc'))) + + with e -> begin + (ignore (E.log "Error in doStatement (%s)\n" (Printexc.to_string e))); + consLabel "booo_statement" empty (convLoc (A.get_statementloc s)) false + end + + +(* Translate a file *) +let convFile ((fname : string), (dl : Cabs.definition list)) : Cil.file = + Cil.initCIL (); (* make sure we have initialized CIL *) + (* Clean up the global types *) + E.hadErrors := false; + initGlobals(); + startFile (); + IH.clear noProtoFunctions; + H.clear compInfoNameEnv; + H.clear enumInfoNameEnv; + IH.clear mustTurnIntoDef; + H.clear alreadyDefined; + H.clear staticLocals; + H.clear typedefs; + H.clear isomorphicStructs; + annonCompFieldNameId := 0; + if !E.verboseFlag || !Cilutil.printStages then + ignore (E.log "Converting CABS->CIL\n"); + (* Setup the built-ins, but do not add their prototypes to the file *) + let setupBuiltin name (resTyp, argTypes, isva) = + let v = + makeGlobalVar name (TFun(resTyp, + Some (List.map (fun at -> ("", at, [])) + argTypes), + isva, [])) in + ignore (alphaConvertVarAndAddToEnv true v) + in + H.iter setupBuiltin (if !msvcMode then msvcBuiltins else gccBuiltins); + + let globalidx = ref 0 in + let doOneGlobal (d: A.definition) = + let s = doDecl true d in + if isNotEmpty s then + E.s (bug "doDecl returns non-empty statement for global"); + (* See if this is one of the globals which we can leave alone. Increment + * globalidx and see if we must leave this alone. *) + if + (match d with + A.DECDEF _ -> true + | A.FUNDEF _ -> true + | _ -> false) && (incr globalidx; !globalidx = !nocil) then begin + (* Create a file where we put the CABS output *) + let temp_cabs_name = "__temp_cabs" in + let temp_cabs = open_out temp_cabs_name in + (* Now print the CABS in there *) + Cprint.commit (); Cprint.flush (); + let old = !Cprint.out in (* Save the old output channel *) + Cprint.out := temp_cabs; + Cprint.print_def d; + Cprint.commit (); Cprint.flush (); + flush !Cprint.out; + Cprint.out := old; + close_out temp_cabs; + (* Now read everythign in *and create a GText from it *) + let temp_cabs = open_in temp_cabs_name in + let buff = Buffer.create 1024 in + Buffer.add_string buff "// Start of CABS form\n"; + Buffer.add_channel buff temp_cabs (in_channel_length temp_cabs); + Buffer.add_string buff "// End of CABS form\n"; + close_in temp_cabs; + (* Try to pop the last thing in the file *) + (match !theFile with + _ :: rest -> theFile := rest + | _ -> ()); + (* Insert in the file a GText *) + cabsPushGlobal (GText(Buffer.contents buff)) + end + in + List.iter doOneGlobal dl; + let globals = ref (popGlobals ()) in + + IH.clear noProtoFunctions; + IH.clear mustTurnIntoDef; + H.clear alreadyDefined; + H.clear compInfoNameEnv; + H.clear enumInfoNameEnv; + H.clear isomorphicStructs; + H.clear staticLocals; + H.clear typedefs; + H.clear env; + H.clear genv; + IH.clear callTempVars; + + if false then ignore (E.log "Cabs2cil converted %d globals\n" !globalidx); + (* We are done *) + { fileName = fname; + globals = !globals; + globinit = None; + globinitcalled = false; + } + + + + diff --git a/cil/src/frontc/cabs2cil.mli b/cil/src/frontc/cabs2cil.mli new file mode 100644 index 0000000..986f5a2 --- /dev/null +++ b/cil/src/frontc/cabs2cil.mli @@ -0,0 +1,49 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +val convFile: Cabs.file -> Cil.file + +(** NDC added command line parameter **) +(* Turn on tranformation that forces correct parameter evaluation order *) +val forceRLArgEval: bool ref + +(* Set this integer to the index of the global to be left in CABS form. Use + * -1 to disable *) +val nocil: int ref + +(* Indicates whether we're allowed to duplicate small chunks of code. *) +val allowDuplication: bool ref diff --git a/cil/src/frontc/cabsvisit.ml b/cil/src/frontc/cabsvisit.ml new file mode 100644 index 0000000..b2f9784 --- /dev/null +++ b/cil/src/frontc/cabsvisit.ml @@ -0,0 +1,577 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* cabsvisit.ml *) +(* tree visitor and rewriter for cabs *) + +open Cabs +open Trace +open Pretty +module E = Errormsg + +(* basic interface for a visitor object *) + +(* Different visiting actions. 'a will be instantiated with exp, instr, etc. *) +type 'a visitAction = + SkipChildren (* Do not visit the children. Return + * the node as it is *) + | ChangeTo of 'a (* Replace the expression with the + * given one *) + | DoChildren (* Continue with the children of this + * node. Rebuild the node on return + * if any of the children changes + * (use == test) *) + | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire + * exp is replaced by the first + * paramenter. Then continue with + * the children. On return rebuild + * the node if any of the children + * has changed and then apply the + * function on the node *) + +type nameKind = + NVar (* Variable or function prototype + name *) + | NFun (* A function definition name *) + | NField (* The name of a field *) + | NType (* The name of a type *) + +(* All visit methods are called in preorder! (but you can use + * ChangeDoChildrenPost to change the order) *) +class type cabsVisitor = object + method vexpr: expression -> expression visitAction (* expressions *) + method vinitexpr: init_expression -> init_expression visitAction + method vstmt: statement -> statement list visitAction + method vblock: block -> block visitAction + method vvar: string -> string (* use of a variable + * names *) + method vdef: definition -> definition list visitAction + method vtypespec: typeSpecifier -> typeSpecifier visitAction + method vdecltype: decl_type -> decl_type visitAction + + (* For each declaration we call vname *) + method vname: nameKind -> specifier -> name -> name visitAction + method vspec: specifier -> specifier visitAction (* specifier *) + method vattr: attribute -> attribute list visitAction + + method vEnterScope: unit -> unit + method vExitScope: unit -> unit +end + +let visitorLocation = ref { filename = ""; + lineno = -1; + byteno = -1;} + + (* a default visitor which does nothing to the tree *) +class nopCabsVisitor : cabsVisitor = object + method vexpr (e:expression) = DoChildren + method vinitexpr (e:init_expression) = DoChildren + method vstmt (s: statement) = + visitorLocation := get_statementloc s; + DoChildren + method vblock (b: block) = DoChildren + method vvar (s: string) = s + method vdef (d: definition) = + visitorLocation := get_definitionloc d; + DoChildren + method vtypespec (ts: typeSpecifier) = DoChildren + method vdecltype (dt: decl_type) = DoChildren + method vname k (s:specifier) (n: name) = DoChildren + method vspec (s:specifier) = DoChildren + method vattr (a: attribute) = DoChildren + + method vEnterScope () = () + method vExitScope () = () +end + + (* Map but try not to copy the list unless necessary *) +let rec mapNoCopy (f: 'a -> 'a) = function + [] -> [] + | (i :: resti) as li -> + let i' = f i in + let resti' = mapNoCopy f resti in + if i' != i || resti' != resti then i' :: resti' else li + +let rec mapNoCopyList (f: 'a -> 'a list) = function + [] -> [] + | (i :: resti) as li -> + let il' = f i in + let resti' = mapNoCopyList f resti in + match il' with + [i'] when i' == i && resti' == resti -> li + | _ -> il' @ resti' + +let doVisit (vis: cabsVisitor) + (startvisit: 'a -> 'a visitAction) + (children: cabsVisitor -> 'a -> 'a) + (node: 'a) : 'a = + let action = startvisit node in + match action with + SkipChildren -> node + | ChangeTo node' -> node' + | _ -> + let nodepre = match action with + ChangeDoChildrenPost (node', _) -> node' + | _ -> node + in + let nodepost = children vis nodepre in + match action with + ChangeDoChildrenPost (_, f) -> f nodepost + | _ -> nodepost + +(* A visitor for lists *) +let doVisitList (vis: cabsVisitor) + (startvisit: 'a -> 'a list visitAction) + (children: cabsVisitor -> 'a -> 'a) + (node: 'a) : 'a list = + let action = startvisit node in + match action with + SkipChildren -> [node] + | ChangeTo nodes' -> nodes' + | _ -> + let nodespre = match action with + ChangeDoChildrenPost (nodespre, _) -> nodespre + | _ -> [node] + in + let nodespost = mapNoCopy (children vis) nodespre in + match action with + ChangeDoChildrenPost (_, f) -> f nodespost + | _ -> nodespost + + +let rec visitCabsTypeSpecifier (vis: cabsVisitor) (ts: typeSpecifier) = + doVisit vis vis#vtypespec childrenTypeSpecifier ts + +and childrenTypeSpecifier vis ts = + let childrenFieldGroup ((s, nel) as input) = + let s' = visitCabsSpecifier vis s in + let doOneField ((n, eo) as input) = + let n' = visitCabsName vis NField s' n in + let eo' = + match eo with + None -> None + | Some e -> let e' = visitCabsExpression vis e in + if e' != e then Some e' else eo + in + if n' != n || eo' != eo then (n', eo') else input + in + let nel' = mapNoCopy doOneField nel in + if s' != s || nel' != nel then (s', nel') else input + in + match ts with + Tstruct (n, Some fg, extraAttrs) -> + (*(trace "sm" (dprintf "visiting struct %s\n" n));*) + let fg' = mapNoCopy childrenFieldGroup fg in + if fg' != fg then Tstruct( n, Some fg', extraAttrs) else ts + | Tunion (n, Some fg, extraAttrs) -> + let fg' = mapNoCopy childrenFieldGroup fg in + if fg' != fg then Tunion( n, Some fg', extraAttrs) else ts + | Tenum (n, Some ei, extraAttrs) -> + let doOneEnumItem ((s, e, loc) as ei) = + let e' = visitCabsExpression vis e in + if e' != e then (s, e', loc) else ei + in + vis#vEnterScope (); + let ei' = mapNoCopy doOneEnumItem ei in + vis#vExitScope(); + if ei' != ei then Tenum( n, Some ei', extraAttrs) else ts + | TtypeofE e -> + let e' = visitCabsExpression vis e in + if e' != e then TtypeofE e' else ts + | TtypeofT (s, dt) -> + let s' = visitCabsSpecifier vis s in + let dt' = visitCabsDeclType vis false dt in + if s != s' || dt != dt' then TtypeofT (s', dt') else ts + | ts -> ts + +and childrenSpecElem (vis: cabsVisitor) (se: spec_elem) : spec_elem = + match se with + SpecTypedef | SpecInline | SpecStorage _ | SpecPattern _ -> se + | SpecCV _ -> se (* cop out *) + | SpecAttr a -> begin + let al' = visitCabsAttribute vis a in + match al' with + [a''] when a'' == a -> se + | [a''] -> SpecAttr a'' + | _ -> E.s (E.unimp "childrenSpecElem: visitCabsAttribute returned a list") + end + | SpecType ts -> + let ts' = visitCabsTypeSpecifier vis ts in + if ts' != ts then SpecType ts' else se + +and visitCabsSpecifier (vis: cabsVisitor) (s: specifier) : specifier = + doVisit vis vis#vspec childrenSpec s +and childrenSpec vis s = mapNoCopy (childrenSpecElem vis) s + + +and visitCabsDeclType vis (isfundef: bool) (dt: decl_type) : decl_type = + doVisit vis vis#vdecltype (childrenDeclType isfundef) dt +and childrenDeclType isfundef vis dt = + match dt with + JUSTBASE -> dt + | PARENTYPE (prea, dt1, posta) -> + let prea' = mapNoCopyList (visitCabsAttribute vis) prea in + let dt1' = visitCabsDeclType vis isfundef dt1 in + let posta'= mapNoCopyList (visitCabsAttribute vis) posta in + if prea' != prea || dt1' != dt1 || posta' != posta then + PARENTYPE (prea', dt1', posta') else dt + | ARRAY (dt1, al, e) -> + let dt1' = visitCabsDeclType vis isfundef dt1 in + let al' = mapNoCopy (childrenAttribute vis) al in + let e'= visitCabsExpression vis e in + if dt1' != dt1 || al' != al || e' != e then ARRAY(dt1', al', e') else dt + | PTR (al, dt1) -> + let al' = mapNoCopy (childrenAttribute vis) al in + let dt1' = visitCabsDeclType vis isfundef dt1 in + if al' != al || dt1' != dt1 then PTR(al', dt1') else dt + | PROTO (dt1, snl, b) -> + (* Do not propagate isfundef further *) + let dt1' = visitCabsDeclType vis false dt1 in + let _ = vis#vEnterScope () in + let snl' = mapNoCopy (childrenSingleName vis NVar) snl in + (* Exit the scope only if not in a function definition *) + let _ = if not isfundef then vis#vExitScope () in + if dt1' != dt1 || snl' != snl then PROTO(dt1', snl', b) else dt + + +and childrenNameGroup vis (kind: nameKind) ((s, nl) as input) = + let s' = visitCabsSpecifier vis s in + let nl' = mapNoCopy (visitCabsName vis kind s') nl in + if s' != s || nl' != nl then (s', nl') else input + + +and childrenInitNameGroup vis ((s, inl) as input) = + let s' = visitCabsSpecifier vis s in + let inl' = mapNoCopy (childrenInitName vis s') inl in + if s' != s || inl' != inl then (s', inl') else input + +and visitCabsName vis (k: nameKind) (s: specifier) + (n: name) : name = + doVisit vis (vis#vname k s) (childrenName s k) n +and childrenName (s: specifier) (k: nameKind) vis (n: name) : name = + let (sn, dt, al, loc) = n in + let dt' = visitCabsDeclType vis (k = NFun) dt in + let al' = mapNoCopy (childrenAttribute vis) al in + if dt' != dt || al' != al then (sn, dt', al', loc) else n + +and childrenInitName vis (s: specifier) (inn: init_name) : init_name = + let (n, ie) = inn in + let n' = visitCabsName vis NVar s n in + let ie' = visitCabsInitExpression vis ie in + if n' != n || ie' != ie then (n', ie') else inn + +and childrenSingleName vis (k: nameKind) (sn: single_name) : single_name = + let s, n = sn in + let s' = visitCabsSpecifier vis s in + let n' = visitCabsName vis k s' n in + if s' != s || n' != n then (s', n') else sn + +and visitCabsDefinition vis (d: definition) : definition list = + doVisitList vis vis#vdef childrenDefinition d +and childrenDefinition vis d = + match d with + FUNDEF (sn, b, l, lend) -> + let sn' = childrenSingleName vis NFun sn in + let b' = visitCabsBlock vis b in + (* End the scope that was started by childrenFunctionName *) + vis#vExitScope (); + if sn' != sn || b' != b then FUNDEF (sn', b', l, lend) else d + + | DECDEF ((s, inl), l) -> + let s' = visitCabsSpecifier vis s in + let inl' = mapNoCopy (childrenInitName vis s') inl in + if s' != s || inl' != inl then DECDEF ((s', inl'), l) else d + | TYPEDEF (ng, l) -> + let ng' = childrenNameGroup vis NType ng in + if ng' != ng then TYPEDEF (ng', l) else d + | ONLYTYPEDEF (s, l) -> + let s' = visitCabsSpecifier vis s in + if s' != s then ONLYTYPEDEF (s', l) else d + | GLOBASM _ -> d + | PRAGMA (e, l) -> + let e' = visitCabsExpression vis e in + if e' != e then PRAGMA (e', l) else d + | LINKAGE (n, l, dl) -> + let dl' = mapNoCopyList (visitCabsDefinition vis) dl in + if dl' != dl then LINKAGE (n, l, dl') else d + + | TRANSFORMER _ -> d + | EXPRTRANSFORMER _ -> d + +and visitCabsBlock vis (b: block) : block = + doVisit vis vis#vblock childrenBlock b + +and childrenBlock vis (b: block) : block = + let _ = vis#vEnterScope () in + let battrs' = mapNoCopyList (visitCabsAttribute vis) b.battrs in + let bstmts' = mapNoCopyList (visitCabsStatement vis) b.bstmts in + let _ = vis#vExitScope () in + if battrs' != b.battrs || bstmts' != b.bstmts then + { blabels = b.blabels; battrs = battrs'; bstmts = bstmts' } + else + b + +and visitCabsStatement vis (s: statement) : statement list = + doVisitList vis vis#vstmt childrenStatement s +and childrenStatement vis s = + let ve e = visitCabsExpression vis e in + let vs l s = + match visitCabsStatement vis s with + [s'] -> s' + | sl -> BLOCK ({blabels = []; battrs = []; bstmts = sl }, l) + in + match s with + NOP _ -> s + | COMPUTATION (e, l) -> + let e' = ve e in + if e' != e then COMPUTATION (e', l) else s + | BLOCK (b, l) -> + let b' = visitCabsBlock vis b in + if b' != b then BLOCK (b', l) else s + | SEQUENCE (s1, s2, l) -> + let s1' = vs l s1 in + let s2' = vs l s2 in + if s1' != s1 || s2' != s2 then SEQUENCE (s1', s2', l) else s + | IF (e, s1, s2, l) -> + let e' = ve e in + let s1' = vs l s1 in + let s2' = vs l s2 in + if e' != e || s1' != s1 || s2' != s2 then IF (e', s1', s2', l) else s + | WHILE (e, s1, l) -> + let e' = ve e in + let s1' = vs l s1 in + if e' != e || s1' != s1 then WHILE (e', s1', l) else s + | DOWHILE (e, s1, l) -> + let e' = ve e in + let s1' = vs l s1 in + if e' != e || s1' != s1 then DOWHILE (e', s1', l) else s + | FOR (fc1, e2, e3, s4, l) -> + let _ = vis#vEnterScope () in + let fc1' = + match fc1 with + FC_EXP e1 -> + let e1' = ve e1 in + if e1' != e1 then FC_EXP e1' else fc1 + | FC_DECL d1 -> + let d1' = + match visitCabsDefinition vis d1 with + [d1'] -> d1' + | _ -> E.s (E.unimp "visitCabs: for can have only one definition") + in + if d1' != d1 then FC_DECL d1' else fc1 + in + let e2' = ve e2 in + let e3' = ve e3 in + let s4' = vs l s4 in + let _ = vis#vExitScope () in + if fc1' != fc1 || e2' != e2 || e3' != e3 || s4' != s4 + then FOR (fc1', e2', e3', s4', l) else s + | BREAK _ | CONTINUE _ | GOTO _ -> s + | RETURN (e, l) -> + let e' = ve e in + if e' != e then RETURN (e', l) else s + | SWITCH (e, s1, l) -> + let e' = ve e in + let s1' = vs l s1 in + if e' != e || s1' != s1 then SWITCH (e', s1', l) else s + | CASE (e, s1, l) -> + let e' = ve e in + let s1' = vs l s1 in + if e' != e || s1' != s1 then CASE (e', s1', l) else s + | CASERANGE (e1, e2, s3, l) -> + let e1' = ve e1 in + let e2' = ve e2 in + let s3' = vs l s3 in + if e1' != e1 || e2' != e2 || s3' != s3 then + CASERANGE (e1', e2', s3', l) else s + | DEFAULT (s1, l) -> + let s1' = vs l s1 in + if s1' != s1 then DEFAULT (s1', l) else s + | LABEL (n, s1, l) -> + let s1' = vs l s1 in + if s1' != s1 then LABEL (n, s1', l) else s + | COMPGOTO (e, l) -> + let e' = ve e in + if e' != e then COMPGOTO (e', l) else s + | DEFINITION d -> begin + match visitCabsDefinition vis d with + [d'] when d' == d -> s + | [d'] -> DEFINITION d' + | dl -> let l = get_definitionloc d in + let dl' = List.map (fun d' -> DEFINITION d') dl in + BLOCK ({blabels = []; battrs = []; bstmts = dl' }, l) + end + | ASM (sl, b, details, l) -> + let childrenStringExp ((s, e) as input) = + let e' = ve e in + if e' != e then (s, e') else input + in + let details' = match details with + | None -> details + | Some { aoutputs = outl; ainputs = inl; aclobbers = clobs } -> + let outl' = mapNoCopy childrenStringExp outl in + let inl' = mapNoCopy childrenStringExp inl in + if outl' == outl && inl' == inl then + details + else + Some { aoutputs = outl'; ainputs = inl'; aclobbers = clobs } + in + if details' != details then + ASM (sl, b, details', l) else s + | TRY_FINALLY (b1, b2, l) -> + let b1' = visitCabsBlock vis b1 in + let b2' = visitCabsBlock vis b2 in + if b1' != b1 || b2' != b2 then TRY_FINALLY(b1', b2', l) else s + | TRY_EXCEPT (b1, e, b2, l) -> + let b1' = visitCabsBlock vis b1 in + let e' = visitCabsExpression vis e in + let b2' = visitCabsBlock vis b2 in + if b1' != b1 || e' != e || b2' != b2 then TRY_EXCEPT(b1', e', b2', l) else s + + +and visitCabsExpression vis (e: expression) : expression = + doVisit vis vis#vexpr childrenExpression e +and childrenExpression vis e = + let ve e = visitCabsExpression vis e in + match e with + NOTHING | LABELADDR _ -> e + | UNARY (uo, e1) -> + let e1' = ve e1 in + if e1' != e1 then UNARY (uo, e1') else e + | BINARY (bo, e1, e2) -> + let e1' = ve e1 in + let e2' = ve e2 in + if e1' != e1 || e2' != e2 then BINARY (bo, e1', e2') else e + | QUESTION (e1, e2, e3) -> + let e1' = ve e1 in + let e2' = ve e2 in + let e3' = ve e3 in + if e1' != e1 || e2' != e2 || e3' != e3 then + QUESTION (e1', e2', e3') else e + | CAST ((s, dt), ie) -> + let s' = visitCabsSpecifier vis s in + let dt' = visitCabsDeclType vis false dt in + let ie' = visitCabsInitExpression vis ie in + if s' != s || dt' != dt || ie' != ie then CAST ((s', dt'), ie') else e + | CALL (f, el) -> + let f' = ve f in + let el' = mapNoCopy ve el in + if f' != f || el' != el then CALL (f', el') else e + | COMMA el -> + let el' = mapNoCopy ve el in + if el' != el then COMMA (el') else e + | CONSTANT _ -> e + | VARIABLE s -> + let s' = vis#vvar s in + if s' != s then VARIABLE s' else e + | EXPR_SIZEOF (e1) -> + let e1' = ve e1 in + if e1' != e1 then EXPR_SIZEOF (e1') else e + | TYPE_SIZEOF (s, dt) -> + let s' = visitCabsSpecifier vis s in + let dt' = visitCabsDeclType vis false dt in + if s' != s || dt' != dt then TYPE_SIZEOF (s' ,dt') else e + | EXPR_ALIGNOF (e1) -> + let e1' = ve e1 in + if e1' != e1 then EXPR_ALIGNOF (e1') else e + | TYPE_ALIGNOF (s, dt) -> + let s' = visitCabsSpecifier vis s in + let dt' = visitCabsDeclType vis false dt in + if s' != s || dt' != dt then TYPE_ALIGNOF (s' ,dt') else e + | INDEX (e1, e2) -> + let e1' = ve e1 in + let e2' = ve e2 in + if e1' != e1 || e2' != e2 then INDEX (e1', e2') else e + | MEMBEROF (e1, n) -> + let e1' = ve e1 in + if e1' != e1 then MEMBEROF (e1', n) else e + | MEMBEROFPTR (e1, n) -> + let e1' = ve e1 in + if e1' != e1 then MEMBEROFPTR (e1', n) else e + | GNU_BODY b -> + let b' = visitCabsBlock vis b in + if b' != b then GNU_BODY b' else e + | EXPR_PATTERN _ -> e + +and visitCabsInitExpression vis (ie: init_expression) : init_expression = + doVisit vis vis#vinitexpr childrenInitExpression ie +and childrenInitExpression vis ie = + let rec childrenInitWhat iw = + match iw with + NEXT_INIT -> iw + | INFIELD_INIT (n, iw1) -> + let iw1' = childrenInitWhat iw1 in + if iw1' != iw1 then INFIELD_INIT (n, iw1') else iw + | ATINDEX_INIT (e, iw1) -> + let e' = visitCabsExpression vis e in + let iw1' = childrenInitWhat iw1 in + if e' != e || iw1' != iw1 then ATINDEX_INIT (e', iw1') else iw + | ATINDEXRANGE_INIT (e1, e2) -> + let e1' = visitCabsExpression vis e1 in + let e2' = visitCabsExpression vis e2 in + if e1' != e1 || e2' != e2 then ATINDEXRANGE_INIT (e1, e2) else iw + in + match ie with + NO_INIT -> ie + | SINGLE_INIT e -> + let e' = visitCabsExpression vis e in + if e' != e then SINGLE_INIT e' else ie + | COMPOUND_INIT il -> + let childrenOne ((iw, ie) as input) = + let iw' = childrenInitWhat iw in + let ie' = visitCabsInitExpression vis ie in + if iw' != iw || ie' != ie then (iw', ie') else input + in + let il' = mapNoCopy childrenOne il in + if il' != il then COMPOUND_INIT il' else ie + + +and visitCabsAttribute vis (a: attribute) : attribute list = + doVisitList vis vis#vattr childrenAttribute a + +and childrenAttribute vis ((n, el) as input) = + let el' = mapNoCopy (visitCabsExpression vis) el in + if el' != el then (n, el') else input + +and visitCabsAttributes vis (al: attribute list) : attribute list = + mapNoCopyList (visitCabsAttribute vis) al + +let visitCabsFile (vis: cabsVisitor) ((fname, f): file) : file = + (fname, mapNoCopyList (visitCabsDefinition vis) f) + + (* end of file *) + diff --git a/cil/src/frontc/cabsvisit.mli b/cil/src/frontc/cabsvisit.mli new file mode 100644 index 0000000..d238789 --- /dev/null +++ b/cil/src/frontc/cabsvisit.mli @@ -0,0 +1,115 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* cabsvisit.mli *) +(* interface for cabsvisit.ml *) + +(* Different visiting actions. 'a will be instantiated with exp, instr, etc. *) +type 'a visitAction = + SkipChildren (* Do not visit the children. Return + * the node as it is *) + | ChangeTo of 'a (* Replace the expression with the + * given one *) + | DoChildren (* Continue with the children of this + * node. Rebuild the node on return + * if any of the children changes + * (use == test) *) + | ChangeDoChildrenPost of 'a * ('a -> 'a) (* First consider that the entire + * exp is replaced by the first + * paramenter. Then continue with + * the children. On return rebuild + * the node if any of the children + * has changed and then apply the + * function on the node *) + +type nameKind = + NVar (** Variable or function prototype + name *) + | NFun (** Function definition name *) + | NField (** The name of a field *) + | NType (** The name of a type *) + + +(* All visit methods are called in preorder! (but you can use + * ChangeDoChildrenPost to change the order) *) +class type cabsVisitor = object + method vexpr: Cabs.expression -> Cabs.expression visitAction (* expressions *) + method vinitexpr: Cabs.init_expression -> Cabs.init_expression visitAction + method vstmt: Cabs.statement -> Cabs.statement list visitAction + method vblock: Cabs.block -> Cabs.block visitAction + method vvar: string -> string (* use of a variable + * names *) + method vdef: Cabs.definition -> Cabs.definition list visitAction + method vtypespec: Cabs.typeSpecifier -> Cabs.typeSpecifier visitAction + method vdecltype: Cabs.decl_type -> Cabs.decl_type visitAction + + (* For each declaration we call vname *) + method vname: nameKind -> Cabs.specifier -> Cabs.name -> Cabs.name visitAction + method vspec: Cabs.specifier -> Cabs.specifier visitAction (* specifier *) + method vattr: Cabs.attribute -> Cabs.attribute list visitAction + + + method vEnterScope: unit -> unit + method vExitScope: unit -> unit +end + + +class nopCabsVisitor: cabsVisitor + + +val visitCabsTypeSpecifier: cabsVisitor -> + Cabs.typeSpecifier -> Cabs.typeSpecifier +val visitCabsSpecifier: cabsVisitor -> Cabs.specifier -> Cabs.specifier + +(** Visits a decl_type. The bool argument is saying whether we are ina + * function definition and thus the scope in a PROTO should extend until the + * end of the function *) +val visitCabsDeclType: cabsVisitor -> bool -> Cabs.decl_type -> Cabs.decl_type +val visitCabsDefinition: cabsVisitor -> Cabs.definition -> Cabs.definition list +val visitCabsBlock: cabsVisitor -> Cabs.block -> Cabs.block +val visitCabsStatement: cabsVisitor -> Cabs.statement -> Cabs.statement list +val visitCabsExpression: cabsVisitor -> Cabs.expression -> Cabs.expression +val visitCabsAttributes: cabsVisitor -> Cabs.attribute list + -> Cabs.attribute list +val visitCabsName: cabsVisitor -> nameKind + -> Cabs.specifier -> Cabs.name -> Cabs.name +val visitCabsFile: cabsVisitor -> Cabs.file -> Cabs.file + + + +(** Set by the visitor to the current location *) +val visitorLocation: Cabs.cabsloc ref diff --git a/cil/src/frontc/clexer.mli b/cil/src/frontc/clexer.mli new file mode 100644 index 0000000..01acfd0 --- /dev/null +++ b/cil/src/frontc/clexer.mli @@ -0,0 +1,55 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + +(* This interface is generated manually. The corresponding .ml file is + * generated automatically and is placed in ../obj/clexer.ml. The reason we + * want this interface is to avoid confusing make with freshly generated + * interface files *) + + +val init: filename:string -> Lexing.lexbuf +val finish: unit -> unit + +(* This is the main parser function *) +val initial: Lexing.lexbuf -> Cparser.token + + +val push_context: unit -> unit (* Start a context *) +val add_type: string -> unit (* Add a new string as a type name *) +val add_identifier: string -> unit (* Add a new string as a variable name *) +val pop_context: unit -> unit (* Remove all names added in this context *) diff --git a/cil/src/frontc/clexer.mll b/cil/src/frontc/clexer.mll new file mode 100644 index 0000000..08f7881 --- /dev/null +++ b/cil/src/frontc/clexer.mll @@ -0,0 +1,664 @@ +(* + * + * Copyright (c) 2001-2003, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Ben Liblit + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +(* FrontC -- lexical analyzer +** +** 1.0 3.22.99 Hugues Cassé First version. +** 2.0 George Necula 12/12/00: Many extensions +*) +{ +open Cparser +open Pretty +exception Eof +exception InternalError of string +module E = Errormsg +module H = Hashtbl + +let matchingParsOpen = ref 0 + +let currentLoc () = + let l, f, c = E.getPosition () in + { Cabs.lineno = l; + Cabs.filename = f; + Cabs.byteno = c;} + +(* string -> unit *) +let addComment c = + let l = currentLoc() in + let i = GrowArray.max_init_index Cabs.commentsGA in + GrowArray.setg Cabs.commentsGA (i+1) (l,c,false) + +let int64_to_char value = + if (compare value (Int64.of_int 255) > 0) || (compare value Int64.zero < 0) then + begin + let msg = Printf.sprintf "clexer:intlist_to_string: character 0x%Lx too big" value in + E.parse_error msg; + end + else + Char.chr (Int64.to_int value) + +(* takes a not-nul-terminated list, and converts it to a string. *) +let rec intlist_to_string (str: int64 list):string = + match str with + [] -> "" (* add nul-termination *) + | value::rest -> + let this_char = int64_to_char value in + (String.make 1 this_char) ^ (intlist_to_string rest) + +(* Some debugging support for line numbers *) +let dbgToken (t: token) = + if false then begin + ignore (E.log "%a" insert + (match t with + IDENT (n, l) -> dprintf "IDENT(%s,%d)\n" n l.Cabs.lineno + | LBRACE l -> dprintf "LBRACE(%d)\n" l.Cabs.lineno + | RBRACE l -> dprintf "RBRACE(%d)\n" l.Cabs.lineno + | IF l -> dprintf "IF(%d)\n" l.Cabs.lineno + | SWITCH l -> dprintf "SWITCH(%d)\n" l.Cabs.lineno + | RETURN l -> dprintf "RETURN(%d)\n" l.Cabs.lineno + | _ -> nil)); + t + end else + t + + +(* +** Keyword hashtable +*) +let lexicon = H.create 211 +let init_lexicon _ = + H.clear lexicon; + List.iter + (fun (key, builder) -> H.add lexicon key builder) + [ ("auto", fun loc -> AUTO loc); + ("const", fun loc -> CONST loc); + ("__const", fun loc -> CONST loc); + ("__const__", fun loc -> CONST loc); + ("static", fun loc -> STATIC loc); + ("extern", fun loc -> EXTERN loc); + ("long", fun loc -> LONG loc); + ("short", fun loc -> SHORT loc); + ("register", fun loc -> REGISTER loc); + ("signed", fun loc -> SIGNED loc); + ("__signed", fun loc -> SIGNED loc); + ("unsigned", fun loc -> UNSIGNED loc); + ("volatile", fun loc -> VOLATILE loc); + ("__volatile", fun loc -> VOLATILE loc); + (* WW: see /usr/include/sys/cdefs.h for why __signed and __volatile + * are accepted GCC-isms *) + ("char", fun loc -> CHAR loc); + ("int", fun loc -> INT loc); + ("float", fun loc -> FLOAT loc); + ("double", fun loc -> DOUBLE loc); + ("void", fun loc -> VOID loc); + ("enum", fun loc -> ENUM loc); + ("struct", fun loc -> STRUCT loc); + ("typedef", fun loc -> TYPEDEF loc); + ("union", fun loc -> UNION loc); + ("break", fun loc -> BREAK loc); + ("continue", fun loc -> CONTINUE loc); + ("goto", fun loc -> GOTO loc); + ("return", fun loc -> dbgToken (RETURN loc)); + ("switch", fun loc -> dbgToken (SWITCH loc)); + ("case", fun loc -> CASE loc); + ("default", fun loc -> DEFAULT loc); + ("while", fun loc -> WHILE loc); + ("do", fun loc -> DO loc); + ("for", fun loc -> FOR loc); + ("if", fun loc -> dbgToken (IF loc)); + ("else", fun _ -> ELSE); + (*** Implementation specific keywords ***) + ("__signed__", fun loc -> SIGNED loc); + ("__inline__", fun loc -> INLINE loc); + ("inline", fun loc -> INLINE loc); + ("__inline", fun loc -> INLINE loc); + ("_inline", fun loc -> INLINE loc); + ("__attribute__", fun loc -> ATTRIBUTE loc); + ("__attribute", fun loc -> ATTRIBUTE loc); +(* + ("__attribute_used__", fun loc -> ATTRIBUTE_USED loc); +*) + ("__blockattribute__", fun _ -> BLOCKATTRIBUTE); + ("__blockattribute", fun _ -> BLOCKATTRIBUTE); + ("__asm__", fun loc -> ASM loc); + ("asm", fun loc -> ASM loc); + ("__typeof__", fun loc -> TYPEOF loc); + ("__typeof", fun loc -> TYPEOF loc); + ("typeof", fun loc -> TYPEOF loc); + ("__alignof", fun loc -> ALIGNOF loc); + ("__alignof__", fun loc -> ALIGNOF loc); + ("__volatile__", fun loc -> VOLATILE loc); + ("__volatile", fun loc -> VOLATILE loc); + + ("__FUNCTION__", fun loc -> FUNCTION__ loc); + ("__func__", fun loc -> FUNCTION__ loc); (* ISO 6.4.2.2 *) + ("__PRETTY_FUNCTION__", fun loc -> PRETTY_FUNCTION__ loc); + ("__label__", fun _ -> LABEL__); + (*** weimer: GCC arcana ***) + ("__restrict", fun loc -> RESTRICT loc); + ("restrict", fun loc -> RESTRICT loc); +(* ("__extension__", EXTENSION); *) + (**** MS VC ***) + ("__int64", fun _ -> INT64 (currentLoc ())); + ("__int32", fun loc -> INT loc); + ("_cdecl", fun _ -> MSATTR ("_cdecl", currentLoc ())); + ("__cdecl", fun _ -> MSATTR ("__cdecl", currentLoc ())); + ("_stdcall", fun _ -> MSATTR ("_stdcall", currentLoc ())); + ("__stdcall", fun _ -> MSATTR ("__stdcall", currentLoc ())); + ("_fastcall", fun _ -> MSATTR ("_fastcall", currentLoc ())); + ("__fastcall", fun _ -> MSATTR ("__fastcall", currentLoc ())); + ("__w64", fun _ -> MSATTR("__w64", currentLoc ())); + ("__declspec", fun loc -> DECLSPEC loc); + ("__forceinline", fun loc -> INLINE loc); (* !! we turn forceinline + * into inline *) + ("__try", fun loc -> TRY loc); + ("__except", fun loc -> EXCEPT loc); + ("__finally", fun loc -> FINALLY loc); + (* weimer: some files produced by 'GCC -E' expect this type to be + * defined *) + ("__builtin_va_list", + fun _ -> NAMED_TYPE ("__builtin_va_list", currentLoc ())); + ("__builtin_va_arg", fun loc -> BUILTIN_VA_ARG loc); + ("__builtin_types_compatible_p", fun loc -> BUILTIN_TYPES_COMPAT loc); + ("__builtin_offsetof", fun loc -> BUILTIN_OFFSETOF loc); + (* On some versions of GCC __thread is a regular identifier *) + ("__thread", fun loc -> + if Machdep.__thread_is_keyword then + THREAD loc + else + IDENT ("__thread", loc)); + ] + +(* Mark an identifier as a type name. The old mapping is preserved and will + * be reinstated when we exit this context *) +let add_type name = + (* ignore (print_string ("adding type name " ^ name ^ "\n")); *) + H.add lexicon name (fun loc -> NAMED_TYPE (name, loc)) + +let context : string list list ref = ref [] + +let push_context _ = context := []::!context + +let pop_context _ = + match !context with + [] -> raise (InternalError "Empty context stack") + | con::sub -> + (context := sub; + List.iter (fun name -> + (* ignore (print_string ("removing lexicon for " ^ name ^ "\n")); *) + H.remove lexicon name) con) + +(* Mark an identifier as a variable name. The old mapping is preserved and + * will be reinstated when we exit this context *) +let add_identifier name = + match !context with + [] -> () (* Just ignore raise (InternalError "Empty context stack") *) + | con::sub -> + (context := (name::con)::sub; + (* print_string ("adding IDENT for " ^ name ^ "\n"); *) + H.add lexicon name (fun loc -> + dbgToken (IDENT (name, loc)))) + + +(* +** Useful primitives +*) +let scan_ident id = + let here = currentLoc () in + try (H.find lexicon id) here + (* default to variable name, as opposed to type *) + with Not_found -> dbgToken (IDENT (id, here)) + + +(* +** Buffer processor +*) + + +let init ~(filename: string) : Lexing.lexbuf = + init_lexicon (); + (* Inititialize the pointer in Errormsg *) + Lexerhack.add_type := add_type; + Lexerhack.push_context := push_context; + Lexerhack.pop_context := pop_context; + Lexerhack.add_identifier := add_identifier; + E.startParsing filename + + +let finish () = + E.finishParsing () + +(*** Error handling ***) +let error msg = + E.parse_error msg + + +(*** escape character management ***) +let scan_escape (char: char) : int64 = + let result = match char with + 'n' -> '\n' + | 'r' -> '\r' + | 't' -> '\t' + | 'b' -> '\b' + | 'f' -> '\012' (* ASCII code 12 *) + | 'v' -> '\011' (* ASCII code 11 *) + | 'a' -> '\007' (* ASCII code 7 *) + | 'e' | 'E' -> '\027' (* ASCII code 27. This is a GCC extension *) + | '\'' -> '\'' + | '"'-> '"' (* '"' *) + | '?' -> '?' + | '(' when not !Cprint.msvcMode -> '(' + | '{' when not !Cprint.msvcMode -> '{' + | '[' when not !Cprint.msvcMode -> '[' + | '%' when not !Cprint.msvcMode -> '%' + | '\\' -> '\\' + | other -> error ("Unrecognized escape sequence: \\" ^ (String.make 1 other)) + in + Int64.of_int (Char.code result) + +let scan_hex_escape str = + let radix = Int64.of_int 16 in + let the_value = ref Int64.zero in + (* start at character 2 to skip the \x *) + for i = 2 to (String.length str) - 1 do + let thisDigit = Cabs.valueOfDigit (String.get str i) in + (* the_value := !the_value * 16 + thisDigit *) + the_value := Int64.add (Int64.mul !the_value radix) thisDigit + done; + !the_value + +let scan_oct_escape str = + let radix = Int64.of_int 8 in + let the_value = ref Int64.zero in + (* start at character 1 to skip the \x *) + for i = 1 to (String.length str) - 1 do + let thisDigit = Cabs.valueOfDigit (String.get str i) in + (* the_value := !the_value * 8 + thisDigit *) + the_value := Int64.add (Int64.mul !the_value radix) thisDigit + done; + !the_value + +let lex_hex_escape remainder lexbuf = + let prefix = scan_hex_escape (Lexing.lexeme lexbuf) in + prefix :: remainder lexbuf + +let lex_oct_escape remainder lexbuf = + let prefix = scan_oct_escape (Lexing.lexeme lexbuf) in + prefix :: remainder lexbuf + +let lex_simple_escape remainder lexbuf = + let lexchar = Lexing.lexeme_char lexbuf 1 in + let prefix = scan_escape lexchar in + prefix :: remainder lexbuf + +let lex_unescaped remainder lexbuf = + let prefix = Int64.of_int (Char.code (Lexing.lexeme_char lexbuf 0)) in + prefix :: remainder lexbuf + +let lex_comment remainder lexbuf = + let ch = Lexing.lexeme_char lexbuf 0 in + let prefix = Int64.of_int (Char.code ch) in + if ch = '\n' then E.newline(); + prefix :: remainder lexbuf + +let make_char (i:int64):char = + let min_val = Int64.zero in + let max_val = Int64.of_int 255 in + (* if i < 0 || i > 255 then error*) + if compare i min_val < 0 || compare i max_val > 0 then begin + let msg = Printf.sprintf "clexer:make_char: character 0x%Lx too big" i in + error msg + end; + Char.chr (Int64.to_int i) + + +(* ISO standard locale-specific function to convert a wide character + * into a sequence of normal characters. Here we work on strings. + * We convert L"Hi" to "H\000i\000" + matth: this seems unused. +let wbtowc wstr = + let len = String.length wstr in + let dest = String.make (len * 2) '\000' in + for i = 0 to len-1 do + dest.[i*2] <- wstr.[i] ; + done ; + dest +*) + +(* This function converst the "Hi" in L"Hi" to { L'H', L'i', L'\0' } + matth: this seems unused. +let wstr_to_warray wstr = + let len = String.length wstr in + let res = ref "{ " in + for i = 0 to len-1 do + res := !res ^ (Printf.sprintf "L'%c', " wstr.[i]) + done ; + res := !res ^ "}" ; + !res +*) + +(* Pragmas get explicit end-of-line tokens. + * Elsewhere they are silently discarded as whitespace. *) +let pragmaLine = ref false + +} + +let decdigit = ['0'-'9'] +let octdigit = ['0'-'7'] +let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F'] +let letter = ['a'- 'z' 'A'-'Z'] + + +let usuffix = ['u' 'U'] +let lsuffix = "l"|"L"|"ll"|"LL" +let intsuffix = lsuffix | usuffix | usuffix lsuffix | lsuffix usuffix + | usuffix ? "i64" + + +let hexprefix = '0' ['x' 'X'] + +let intnum = decdigit+ intsuffix? +let octnum = '0' octdigit+ intsuffix? +let hexnum = hexprefix hexdigit+ intsuffix? + +let exponent = ['e' 'E']['+' '-']? decdigit+ +let fraction = '.' decdigit+ +let decfloat = (intnum? fraction) + |(intnum exponent) + |(intnum? fraction exponent) + | (intnum '.') + | (intnum '.' exponent) + +let hexfraction = hexdigit* '.' hexdigit+ | hexdigit+ +let binexponent = ['p' 'P'] ['+' '-']? decdigit+ +let hexfloat = hexprefix hexfraction binexponent + | hexprefix hexdigit+ binexponent + +let floatsuffix = ['f' 'F' 'l' 'L'] +let floatnum = (decfloat | hexfloat) floatsuffix? + +let ident = (letter|'_')(letter|decdigit|'_'|'$')* +let blank = [' ' '\t' '\012' '\r']+ +let escape = '\\' _ +let hex_escape = '\\' ['x' 'X'] hexdigit+ +let oct_escape = '\\' octdigit octdigit? octdigit? + +(* Pragmas that are not parsed by CIL. We lex them as PRAGMA_LINE tokens *) +let no_parse_pragma = + "warning" | "GCC" + (* Solaris-style pragmas: *) + | "ident" | "section" | "option" | "asm" | "use_section" | "weak" + | "redefine_extname" + | "TCS_align" + + +rule initial = + parse "/*" { let il = comment lexbuf in + let sl = intlist_to_string il in + addComment sl; + initial lexbuf} +| "//" { let il = onelinecomment lexbuf in + let sl = intlist_to_string il in + addComment sl; + E.newline(); + initial lexbuf + } +| blank {initial lexbuf} +| '\n' { E.newline (); + if !pragmaLine then + begin + pragmaLine := false; + PRAGMA_EOL + end + else + initial lexbuf } +| '\\' '\r' * '\n' { + E.newline (); + initial lexbuf + } +| '#' { hash lexbuf} +| "_Pragma" { PRAGMA (currentLoc ()) } +| '\'' { CST_CHAR (chr lexbuf, currentLoc ())} +| "L'" { CST_WCHAR (chr lexbuf, currentLoc ()) } +| '"' { (* '"' *) +(* matth: BUG: this could be either a regular string or a wide string. + * e.g. if it's the "world" in + * L"Hello, " "world" + * then it should be treated as wide even though there's no L immediately + * preceding it. See test/small1/wchar5.c for a failure case. *) + try CST_STRING (str lexbuf, currentLoc ()) + with e -> + raise (InternalError + ("str: " ^ + Printexc.to_string e))} +| "L\"" { (* weimer: wchar_t string literal *) + try CST_WSTRING(str lexbuf, currentLoc ()) + with e -> + raise (InternalError + ("wide string: " ^ + Printexc.to_string e))} +| floatnum {CST_FLOAT (Lexing.lexeme lexbuf, currentLoc ())} +| hexnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} +| octnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} +| intnum {CST_INT (Lexing.lexeme lexbuf, currentLoc ())} +| "!quit!" {EOF} +| "..." {ELLIPSIS} +| "+=" {PLUS_EQ} +| "-=" {MINUS_EQ} +| "*=" {STAR_EQ} +| "/=" {SLASH_EQ} +| "%=" {PERCENT_EQ} +| "|=" {PIPE_EQ} +| "&=" {AND_EQ} +| "^=" {CIRC_EQ} +| "<<=" {INF_INF_EQ} +| ">>=" {SUP_SUP_EQ} +| "<<" {INF_INF} +| ">>" {SUP_SUP} +| "==" {EQ_EQ} +| "!=" {EXCLAM_EQ} +| "<=" {INF_EQ} +| ">=" {SUP_EQ} +| "=" {EQ} +| "<" {INF} +| ">" {SUP} +| "++" {PLUS_PLUS (currentLoc ())} +| "--" {MINUS_MINUS (currentLoc ())} +| "->" {ARROW} +| '+' {PLUS (currentLoc ())} +| '-' {MINUS (currentLoc ())} +| '*' {STAR (currentLoc ())} +| '/' {SLASH} +| '%' {PERCENT} +| '!' {EXCLAM (currentLoc ())} +| "&&" {AND_AND (currentLoc ())} +| "||" {PIPE_PIPE} +| '&' {AND (currentLoc ())} +| '|' {PIPE} +| '^' {CIRC} +| '?' {QUEST} +| ':' {COLON} +| '~' {TILDE (currentLoc ())} + +| '{' {dbgToken (LBRACE (currentLoc ()))} +| '}' {dbgToken (RBRACE (currentLoc ()))} +| '[' {LBRACKET} +| ']' {RBRACKET} +| '(' {dbgToken (LPAREN (currentLoc ())) } +| ')' {RPAREN} +| ';' {dbgToken (SEMICOLON (currentLoc ())) } +| ',' {COMMA} +| '.' {DOT} +| "sizeof" {SIZEOF (currentLoc ())} +| "__asm" { if !Cprint.msvcMode then + MSASM (msasm lexbuf, currentLoc ()) + else (ASM (currentLoc ())) } + +(* If we see __pragma we eat it and the matching parentheses as well *) +| "__pragma" { matchingParsOpen := 0; + let _ = matchingpars lexbuf in + initial lexbuf + } + +(* sm: tree transformation keywords *) +| "@transform" {AT_TRANSFORM (currentLoc ())} +| "@transformExpr" {AT_TRANSFORMEXPR (currentLoc ())} +| "@specifier" {AT_SPECIFIER (currentLoc ())} +| "@expr" {AT_EXPR (currentLoc ())} +| "@name" {AT_NAME} + +(* __extension__ is a black. The parser runs into some conflicts if we let it + * pass *) +| "__extension__" {initial lexbuf } +| ident {scan_ident (Lexing.lexeme lexbuf)} +| eof {EOF} +| _ {E.parse_error "Invalid symbol"} +and comment = + parse + "*/" { [] } +(*| '\n' { E.newline (); lex_unescaped comment lexbuf }*) +| _ { lex_comment comment lexbuf } + + +and onelinecomment = parse + '\n' {[]} +| _ { lex_comment onelinecomment lexbuf } + +and matchingpars = parse + '\n' { E.newline (); matchingpars lexbuf } +| blank { matchingpars lexbuf } +| '(' { incr matchingParsOpen; matchingpars lexbuf } +| ')' { decr matchingParsOpen; + if !matchingParsOpen = 0 then + () + else + matchingpars lexbuf + } +| "/*" { let il = comment lexbuf in + let sl = intlist_to_string il in + addComment sl; + matchingpars lexbuf} +| '"' { (* '"' *) + let _ = str lexbuf in + matchingpars lexbuf + } +| _ { matchingpars lexbuf } + +(* # ... *) +and hash = parse + '\n' { E.newline (); initial lexbuf} +| blank { hash lexbuf} +| intnum { (* We are seeing a line number. This is the number for the + * next line *) + let s = Lexing.lexeme lexbuf in + begin try + E.setCurrentLine (int_of_string s - 1) + with Failure _ -> + E.warn "Bad line number in preprocessed file: %s" s + end; + (* A file name must follow *) + file lexbuf } +| "line" { hash lexbuf } (* MSVC line number info *) + (* For pragmas with irregular syntax, like #pragma warning, + * we parse them as a whole line. *) +| "pragma" blank (no_parse_pragma as pragmaName) + { let here = currentLoc () in + PRAGMA_LINE (pragmaName ^ pragma lexbuf, here) + } +| "pragma" { pragmaLine := true; PRAGMA (currentLoc ()) } +| _ { endline lexbuf} + +and file = parse + '\n' {E.newline (); initial lexbuf} +| blank {file lexbuf} +| '"' [^ '\012' '\t' '"']* '"' { (* '"' *) + let n = Lexing.lexeme lexbuf in + let n1 = String.sub n 1 + ((String.length n) - 2) in + E.setCurrentFile n1; + endline lexbuf} + +| _ {endline lexbuf} + +and endline = parse + '\n' { E.newline (); initial lexbuf} +| eof { EOF } +| _ { endline lexbuf} + +and pragma = parse + '\n' { E.newline (); "" } +| _ { let cur = Lexing.lexeme lexbuf in + cur ^ (pragma lexbuf) } + +and str = parse + '"' {[]} (* no nul terminiation in CST_STRING '"' *) +| hex_escape {lex_hex_escape str lexbuf} +| oct_escape {lex_oct_escape str lexbuf} +| escape {lex_simple_escape str lexbuf} +| _ {lex_unescaped str lexbuf} + +and chr = parse + '\'' {[]} +| hex_escape {lex_hex_escape chr lexbuf} +| oct_escape {lex_oct_escape chr lexbuf} +| escape {lex_simple_escape chr lexbuf} +| _ {lex_unescaped chr lexbuf} + +and msasm = parse + blank { msasm lexbuf } +| '{' { msasminbrace lexbuf } +| _ { let cur = Lexing.lexeme lexbuf in + cur ^ (msasmnobrace lexbuf) } + +and msasminbrace = parse + '}' { "" } +| _ { let cur = Lexing.lexeme lexbuf in + cur ^ (msasminbrace lexbuf) } +and msasmnobrace = parse + ['}' ';' '\n'] { lexbuf.Lexing.lex_curr_pos <- + lexbuf.Lexing.lex_curr_pos - 1; + "" } +| "__asm" { lexbuf.Lexing.lex_curr_pos <- + lexbuf.Lexing.lex_curr_pos - 5; + "" } +| _ { let cur = Lexing.lexeme lexbuf in + + cur ^ (msasmnobrace lexbuf) } + +{ + +} diff --git a/cil/src/frontc/cparser.mly b/cil/src/frontc/cparser.mly new file mode 100644 index 0000000..f1e1ef9 --- /dev/null +++ b/cil/src/frontc/cparser.mly @@ -0,0 +1,1521 @@ +/*(* + * + * Copyright (c) 2001-2003, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Ben Liblit + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + **) +(** +** 1.0 3.22.99 Hugues Cassé First version. +** 2.0 George Necula 12/12/00: Practically complete rewrite. +*) +*/ +%{ +open Cabs +module E = Errormsg + +let parse_error msg : unit = (* sm: c++-mode highlight hack: -> ' <- *) + E.parse_error msg + +let print = print_string + +(* unit -> string option *) +(* +let getComments () = + match !comments with + [] -> None + | _ -> + let r = Some(String.concat "\n" (List.rev !comments)) in + comments := []; + r +*) + +let currentLoc () = + let l, f, c = E.getPosition () in + { lineno = l; + filename = f; + byteno = c;} + +let cabslu = {lineno = -10; + filename = "cabs loc unknown"; + byteno = -10;} + +(* cabsloc -> cabsloc *) +(* +let handleLoc l = + l.clcomment <- getComments(); + l +*) + +(* +** Expression building +*) +let smooth_expression lst = + match lst with + [] -> NOTHING + | [expr] -> expr + | _ -> COMMA (lst) + + +let currentFunctionName = ref "" + +let announceFunctionName ((n, decl, _, _):name) = + !Lexerhack.add_identifier n; + (* Start a context that includes the parameter names and the whole body. + * Will pop when we finish parsing the function body *) + !Lexerhack.push_context (); + (* Go through all the parameter names and mark them as identifiers *) + let rec findProto = function + PROTO (d, args, _) when isJUSTBASE d -> + List.iter (fun (_, (an, _, _, _)) -> !Lexerhack.add_identifier an) args + + | PROTO (d, _, _) -> findProto d + | PARENTYPE (_, d, _) -> findProto d + | PTR (_, d) -> findProto d + | ARRAY (d, _, _) -> findProto d + | _ -> parse_error "Cannot find the prototype in a function definition"; + raise Parsing.Parse_error + + and isJUSTBASE = function + JUSTBASE -> true + | PARENTYPE (_, d, _) -> isJUSTBASE d + | _ -> false + in + findProto decl; + currentFunctionName := n + + + +let applyPointer (ptspecs: attribute list list) (dt: decl_type) + : decl_type = + (* Outer specification first *) + let rec loop = function + [] -> dt + | attrs :: rest -> PTR(attrs, loop rest) + in + loop ptspecs + +let doDeclaration (loc: cabsloc) (specs: spec_elem list) (nl: init_name list) : definition = + if isTypedef specs then begin + (* Tell the lexer about the new type names *) + List.iter (fun ((n, _, _, _), _) -> !Lexerhack.add_type n) nl; + TYPEDEF ((specs, List.map (fun (n, _) -> n) nl), loc) + end else + if nl = [] then + ONLYTYPEDEF (specs, loc) + else begin + (* Tell the lexer about the new variable names *) + List.iter (fun ((n, _, _, _), _) -> !Lexerhack.add_identifier n) nl; + DECDEF ((specs, nl), loc) + end + + +let doFunctionDef (loc: cabsloc) + (lend: cabsloc) + (specs: spec_elem list) + (n: name) + (b: block) : definition = + let fname = (specs, n) in + FUNDEF (fname, b, loc, lend) + + +let doOldParDecl (names: string list) + ((pardefs: name_group list), (isva: bool)) + : single_name list * bool = + let findOneName n = + (* Search in pardefs for the definition for this parameter *) + let rec loopGroups = function + [] -> ([SpecType Tint], (n, JUSTBASE, [], cabslu)) + | (specs, names) :: restgroups -> + let rec loopNames = function + [] -> loopGroups restgroups + | ((n',_, _, _) as sn) :: _ when n' = n -> (specs, sn) + | _ :: restnames -> loopNames restnames + in + loopNames names + in + loopGroups pardefs + in + let args = List.map findOneName names in + (args, isva) + +let checkConnective (s : string) : unit = +begin + (* checking this means I could possibly have more connectives, with *) + (* different meaning *) + if (s <> "to") then ( + parse_error "transformer connective must be 'to'"; + raise Parsing.Parse_error + ) + else () +end + +let int64_to_char value = + if (compare value (Int64.of_int 255) > 0) || (compare value Int64.zero < 0) then + begin + let msg = Printf.sprintf "cparser:intlist_to_string: character 0x%Lx too big" value in + parse_error msg; + raise Parsing.Parse_error + end + else + Char.chr (Int64.to_int value) + +(* takes a not-nul-terminated list, and converts it to a string. *) +let rec intlist_to_string (str: int64 list):string = + match str with + [] -> "" (* add nul-termination *) + | value::rest -> + let this_char = int64_to_char value in + (String.make 1 this_char) ^ (intlist_to_string rest) + +let fst3 (result, _, _) = result +let snd3 (_, result, _) = result +let trd3 (_, _, result) = result + + +(* + transform: __builtin_offsetof(type, member) + into : (size_t) (&(type * ) 0)->member + *) + +let transformOffsetOf (speclist, dtype) member = + let rec addPointer = function + | JUSTBASE -> + PTR([], JUSTBASE) + | PARENTYPE (attrs1, dtype, attrs2) -> + PARENTYPE (attrs1, addPointer dtype, attrs2) + | ARRAY (dtype, attrs, expr) -> + ARRAY (addPointer dtype, attrs, expr) + | PTR (attrs, dtype) -> + PTR (attrs, addPointer dtype) + | PROTO (dtype, names, variadic) -> + PROTO (addPointer dtype, names, variadic) + in + let nullType = (speclist, addPointer dtype) in + let nullExpr = CONSTANT (CONST_INT "0") in + let castExpr = CAST (nullType, SINGLE_INIT nullExpr) in + + let rec replaceBase = function + | VARIABLE field -> + MEMBEROFPTR (castExpr, field) + | MEMBEROF (base, field) -> + MEMBEROF (replaceBase base, field) + | INDEX (base, index) -> + INDEX (replaceBase base, index) + | _ -> + parse_error "malformed offset expression in __builtin_offsetof"; + raise Parsing.Parse_error + in + let memberExpr = replaceBase member in + let addrExpr = UNARY (ADDROF, memberExpr) in + (* slight cheat: hard-coded assumption that size_t == unsigned int *) + let sizeofType = [SpecType Tunsigned], JUSTBASE in + let resultExpr = CAST (sizeofType, SINGLE_INIT addrExpr) in + resultExpr + +%} + +%token IDENT +%token CST_CHAR +%token CST_WCHAR +%token CST_INT +%token CST_FLOAT +%token NAMED_TYPE + +/* Each character is its own list element, and the terminating nul is not + included in this list. */ +%token CST_STRING +%token CST_WSTRING + +%token EOF +%token CHAR INT DOUBLE FLOAT VOID INT64 INT32 +%token ENUM STRUCT TYPEDEF UNION +%token SIGNED UNSIGNED LONG SHORT +%token VOLATILE EXTERN STATIC CONST RESTRICT AUTO REGISTER +%token THREAD + +%token SIZEOF ALIGNOF + +%token EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ +%token AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ +%token ARROW DOT + +%token EQ_EQ EXCLAM_EQ INF SUP INF_EQ SUP_EQ +%token PLUS MINUS STAR +%token SLASH PERCENT +%token TILDE AND +%token PIPE CIRC +%token EXCLAM AND_AND +%token PIPE_PIPE +%token INF_INF SUP_SUP +%token PLUS_PLUS MINUS_MINUS + +%token RPAREN +%token LPAREN RBRACE +%token LBRACE +%token LBRACKET RBRACKET +%token COLON +%token SEMICOLON +%token COMMA ELLIPSIS QUEST + +%token BREAK CONTINUE GOTO RETURN +%token SWITCH CASE DEFAULT +%token WHILE DO FOR +%token IF TRY EXCEPT FINALLY +%token ELSE + +%token ATTRIBUTE INLINE ASM TYPEOF FUNCTION__ PRETTY_FUNCTION__ +%token LABEL__ +%token BUILTIN_VA_ARG ATTRIBUTE_USED +%token BUILTIN_VA_LIST +%token BLOCKATTRIBUTE +%token BUILTIN_TYPES_COMPAT BUILTIN_OFFSETOF +%token DECLSPEC +%token MSASM MSATTR +%token PRAGMA_LINE +%token PRAGMA +%token PRAGMA_EOL + +/* sm: cabs tree transformation specification keywords */ +%token AT_TRANSFORM AT_TRANSFORMEXPR AT_SPECIFIER AT_EXPR +%token AT_NAME + +/* operator precedence */ +%nonassoc IF +%nonassoc ELSE + + +%left COMMA +%right EQ PLUS_EQ MINUS_EQ STAR_EQ SLASH_EQ PERCENT_EQ + AND_EQ PIPE_EQ CIRC_EQ INF_INF_EQ SUP_SUP_EQ +%right QUEST COLON +%left PIPE_PIPE +%left AND_AND +%left PIPE +%left CIRC +%left AND +%left EQ_EQ EXCLAM_EQ +%left INF SUP INF_EQ SUP_EQ +%left INF_INF SUP_SUP +%left PLUS MINUS +%left STAR SLASH PERCENT CONST RESTRICT VOLATILE +%right EXCLAM TILDE PLUS_PLUS MINUS_MINUS CAST RPAREN ADDROF SIZEOF ALIGNOF +%left LBRACKET +%left DOT ARROW LPAREN LBRACE +%right NAMED_TYPE /* We'll use this to handle redefinitions of + * NAMED_TYPE as variables */ +%left IDENT + +/* Non-terminals informations */ +%start interpret file +%type file interpret globals + +%type global + + +%type attributes attributes_with_asm asmattr +%type statement +%type constant +%type string_constant +%type expression +%type opt_expression +%type init_expression +%type comma_expression +%type paren_comma_expression +%type arguments +%type bracket_comma_expression +%type string_list +%type wstring_list + +%type initializer +%type <(Cabs.initwhat * Cabs.init_expression) list> initializer_list +%type init_designators init_designators_opt + +%type decl_spec_list +%type type_spec +%type struct_decl_list + + +%type old_proto_decl +%type parameter_decl +%type enumerator +%type enum_list +%type declaration function_def +%type function_def_start +%type type_name +%type block +%type block_element_list +%type local_labels local_label_names +%type old_parameter_list_ne + +%type init_declarator +%type init_declarator_list +%type declarator +%type field_decl +%type <(Cabs.name * expression option) list> field_decl_list +%type direct_decl +%type abs_direct_decl abs_direct_decl_opt +%type abstract_decl + + /* (* Each element is a "* ". *) */ +%type pointer pointer_opt +%type location +%type cvspec +%% + +interpret: + file EOF {$1} +; +file: globals {$1} +; +globals: + /* empty */ { [] } +| global globals { $1 :: $2 } +| SEMICOLON globals { $2 } +; + +location: + /* empty */ { currentLoc () } %prec IDENT + + +/*** Global Definition ***/ +global: +| declaration { $1 } +| function_def { $1 } +/*(* Some C header files ar shared with the C++ compiler and have linkage + * specification *)*/ +| EXTERN string_constant declaration { LINKAGE (fst $2, (*handleLoc*) (snd $2), [ $3 ]) } +| EXTERN string_constant LBRACE globals RBRACE + { LINKAGE (fst $2, (*handleLoc*) (snd $2), $4) } +| ASM LPAREN string_constant RPAREN SEMICOLON + { GLOBASM (fst $3, (*handleLoc*) $1) } +| pragma { $1 } +/* (* Old-style function prototype. This should be somewhere else, like in + * "declaration". For now we keep it at global scope only because in local + * scope it looks too much like a function call *) */ +| IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list SEMICOLON + { (* Convert pardecl to new style *) + let pardecl, isva = doOldParDecl $3 $5 in + (* Make the function declarator *) + doDeclaration ((*handleLoc*) (snd $1)) [] + [((fst $1, PROTO(JUSTBASE, pardecl,isva), [], cabslu), + NO_INIT)] + } +/* (* Old style function prototype, but without any arguments *) */ +| IDENT LPAREN RPAREN SEMICOLON + { (* Make the function declarator *) + doDeclaration ((*handleLoc*)(snd $1)) [] + [((fst $1, PROTO(JUSTBASE,[],false), [], cabslu), + NO_INIT)] + } +/* transformer for a toplevel construct */ +| AT_TRANSFORM LBRACE global RBRACE IDENT/*to*/ LBRACE globals RBRACE { + checkConnective(fst $5); + TRANSFORMER($3, $7, $1) + } +/* transformer for an expression */ +| AT_TRANSFORMEXPR LBRACE expression RBRACE IDENT/*to*/ LBRACE expression RBRACE { + checkConnective(fst $5); + EXPRTRANSFORMER(fst $3, fst $7, $1) + } +| location error SEMICOLON { PRAGMA (VARIABLE "parse_error", $1) } +; + +id_or_typename: + IDENT {fst $1} +| NAMED_TYPE {fst $1} +| AT_NAME LPAREN IDENT RPAREN { "@name(" ^ fst $3 ^ ")" } /* pattern variable name */ +; + +maybecomma: + /* empty */ { () } +| COMMA { () } +; + +/* *** Expressions *** */ + +primary_expression: /*(* 6.5.1. *)*/ +| IDENT + {VARIABLE (fst $1), snd $1} +| constant + {CONSTANT (fst $1), snd $1} +| paren_comma_expression + {smooth_expression (fst $1), snd $1} +| LPAREN block RPAREN + { GNU_BODY (fst3 $2), $1 } + + /*(* Next is Scott's transformer *)*/ +| AT_EXPR LPAREN IDENT RPAREN /* expression pattern variable */ + { EXPR_PATTERN(fst $3), $1 } +; + +postfix_expression: /*(* 6.5.2 *)*/ +| primary_expression + { $1 } +| postfix_expression bracket_comma_expression + {INDEX (fst $1, smooth_expression $2), snd $1} +| postfix_expression LPAREN arguments RPAREN + {CALL (fst $1, $3), snd $1} +| BUILTIN_VA_ARG LPAREN expression COMMA type_name RPAREN + { let b, d = $5 in + CALL (VARIABLE "__builtin_va_arg", + [fst $3; TYPE_SIZEOF (b, d)]), $1 } +| BUILTIN_TYPES_COMPAT LPAREN type_name COMMA type_name RPAREN + { let b1,d1 = $3 in + let b2,d2 = $5 in + CALL (VARIABLE "__builtin_types_compatible_p", + [TYPE_SIZEOF(b1,d1); TYPE_SIZEOF(b2,d2)]), $1 } +| BUILTIN_OFFSETOF LPAREN type_name COMMA offsetof_member_designator RPAREN + { transformOffsetOf $3 (fst $5), $1 } +| postfix_expression DOT id_or_typename + {MEMBEROF (fst $1, $3), snd $1} +| postfix_expression ARROW id_or_typename + {MEMBEROFPTR (fst $1, $3), snd $1} +| postfix_expression PLUS_PLUS + {UNARY (POSINCR, fst $1), snd $1} +| postfix_expression MINUS_MINUS + {UNARY (POSDECR, fst $1), snd $1} +/* (* We handle GCC constructor expressions *) */ +| LPAREN type_name RPAREN LBRACE initializer_list_opt RBRACE + { CAST($2, COMPOUND_INIT $5), $1 } +; + +offsetof_member_designator: /* GCC extension for __builtin_offsetof */ +| IDENT + { VARIABLE (fst $1), snd $1 } +| offsetof_member_designator DOT IDENT + { MEMBEROF (fst $1, fst $3), snd $1 } +| offsetof_member_designator bracket_comma_expression + { INDEX (fst $1, smooth_expression $2), snd $1 } +; + +unary_expression: /*(* 6.5.3 *)*/ +| postfix_expression + { $1 } +| PLUS_PLUS unary_expression + {UNARY (PREINCR, fst $2), $1} +| MINUS_MINUS unary_expression + {UNARY (PREDECR, fst $2), $1} +| SIZEOF unary_expression + {EXPR_SIZEOF (fst $2), $1} +| SIZEOF LPAREN type_name RPAREN + {let b, d = $3 in TYPE_SIZEOF (b, d), $1} +| ALIGNOF unary_expression + {EXPR_ALIGNOF (fst $2), $1} +| ALIGNOF LPAREN type_name RPAREN + {let b, d = $3 in TYPE_ALIGNOF (b, d), $1} +| PLUS cast_expression + {UNARY (PLUS, fst $2), $1} +| MINUS cast_expression + {UNARY (MINUS, fst $2), $1} +| STAR cast_expression + {UNARY (MEMOF, fst $2), $1} +| AND cast_expression + {UNARY (ADDROF, fst $2), $1} +| EXCLAM cast_expression + {UNARY (NOT, fst $2), $1} +| TILDE cast_expression + {UNARY (BNOT, fst $2), $1} +| AND_AND IDENT { LABELADDR (fst $2), $1 } +; + +cast_expression: /*(* 6.5.4 *)*/ +| unary_expression + { $1 } +| LPAREN type_name RPAREN cast_expression + { CAST($2, SINGLE_INIT (fst $4)), $1 } +; + +multiplicative_expression: /*(* 6.5.5 *)*/ +| cast_expression + { $1 } +| multiplicative_expression STAR cast_expression + {BINARY(MUL, fst $1, fst $3), snd $1} +| multiplicative_expression SLASH cast_expression + {BINARY(DIV, fst $1, fst $3), snd $1} +| multiplicative_expression PERCENT cast_expression + {BINARY(MOD, fst $1, fst $3), snd $1} +; + +additive_expression: /*(* 6.5.6 *)*/ +| multiplicative_expression + { $1 } +| additive_expression PLUS multiplicative_expression + {BINARY(ADD, fst $1, fst $3), snd $1} +| additive_expression MINUS multiplicative_expression + {BINARY(SUB, fst $1, fst $3), snd $1} +; + +shift_expression: /*(* 6.5.7 *)*/ +| additive_expression + { $1 } +| shift_expression INF_INF additive_expression + {BINARY(SHL, fst $1, fst $3), snd $1} +| shift_expression SUP_SUP additive_expression + {BINARY(SHR, fst $1, fst $3), snd $1} +; + + +relational_expression: /*(* 6.5.8 *)*/ +| shift_expression + { $1 } +| relational_expression INF shift_expression + {BINARY(LT, fst $1, fst $3), snd $1} +| relational_expression SUP shift_expression + {BINARY(GT, fst $1, fst $3), snd $1} +| relational_expression INF_EQ shift_expression + {BINARY(LE, fst $1, fst $3), snd $1} +| relational_expression SUP_EQ shift_expression + {BINARY(GE, fst $1, fst $3), snd $1} +; + +equality_expression: /*(* 6.5.9 *)*/ +| relational_expression + { $1 } +| equality_expression EQ_EQ relational_expression + {BINARY(EQ, fst $1, fst $3), snd $1} +| equality_expression EXCLAM_EQ relational_expression + {BINARY(NE, fst $1, fst $3), snd $1} +; + + +bitwise_and_expression: /*(* 6.5.10 *)*/ +| equality_expression + { $1 } +| bitwise_and_expression AND equality_expression + {BINARY(BAND, fst $1, fst $3), snd $1} +; + +bitwise_xor_expression: /*(* 6.5.11 *)*/ +| bitwise_and_expression + { $1 } +| bitwise_xor_expression CIRC bitwise_and_expression + {BINARY(XOR, fst $1, fst $3), snd $1} +; + +bitwise_or_expression: /*(* 6.5.12 *)*/ +| bitwise_xor_expression + { $1 } +| bitwise_or_expression PIPE bitwise_xor_expression + {BINARY(BOR, fst $1, fst $3), snd $1} +; + +logical_and_expression: /*(* 6.5.13 *)*/ +| bitwise_or_expression + { $1 } +| logical_and_expression AND_AND bitwise_or_expression + {BINARY(AND, fst $1, fst $3), snd $1} +; + +logical_or_expression: /*(* 6.5.14 *)*/ +| logical_and_expression + { $1 } +| logical_or_expression PIPE_PIPE logical_and_expression + {BINARY(OR, fst $1, fst $3), snd $1} +; + +conditional_expression: /*(* 6.5.15 *)*/ +| logical_or_expression + { $1 } +| logical_or_expression QUEST opt_expression COLON conditional_expression + {QUESTION (fst $1, $3, fst $5), snd $1} +; + +/*(* The C spec says that left-hand sides of assignment expressions are unary + * expressions. GCC allows cast expressions in there ! *)*/ + +assignment_expression: /*(* 6.5.16 *)*/ +| conditional_expression + { $1 } +| cast_expression EQ assignment_expression + {BINARY(ASSIGN, fst $1, fst $3), snd $1} +| cast_expression PLUS_EQ assignment_expression + {BINARY(ADD_ASSIGN, fst $1, fst $3), snd $1} +| cast_expression MINUS_EQ assignment_expression + {BINARY(SUB_ASSIGN, fst $1, fst $3), snd $1} +| cast_expression STAR_EQ assignment_expression + {BINARY(MUL_ASSIGN, fst $1, fst $3), snd $1} +| cast_expression SLASH_EQ assignment_expression + {BINARY(DIV_ASSIGN, fst $1, fst $3), snd $1} +| cast_expression PERCENT_EQ assignment_expression + {BINARY(MOD_ASSIGN, fst $1, fst $3), snd $1} +| cast_expression AND_EQ assignment_expression + {BINARY(BAND_ASSIGN, fst $1, fst $3), snd $1} +| cast_expression PIPE_EQ assignment_expression + {BINARY(BOR_ASSIGN, fst $1, fst $3), snd $1} +| cast_expression CIRC_EQ assignment_expression + {BINARY(XOR_ASSIGN, fst $1, fst $3), snd $1} +| cast_expression INF_INF_EQ assignment_expression + {BINARY(SHL_ASSIGN, fst $1, fst $3), snd $1} +| cast_expression SUP_SUP_EQ assignment_expression + {BINARY(SHR_ASSIGN, fst $1, fst $3), snd $1} +; + +expression: /*(* 6.5.17 *)*/ + assignment_expression + { $1 } +; + + +constant: + CST_INT {CONST_INT (fst $1), snd $1} +| CST_FLOAT {CONST_FLOAT (fst $1), snd $1} +| CST_CHAR {CONST_CHAR (fst $1), snd $1} +| CST_WCHAR {CONST_WCHAR (fst $1), snd $1} +| string_constant {CONST_STRING (fst $1), snd $1} +| wstring_list {CONST_WSTRING (fst $1), snd $1} +; + +string_constant: +/* Now that we know this constant isn't part of a wstring, convert it + back to a string for easy viewing. */ + string_list { + let queue, location = $1 in + let buffer = Buffer.create (Queue.length queue) in + Queue.iter + (List.iter + (fun value -> + let char = int64_to_char value in + Buffer.add_char buffer char)) + queue; + Buffer.contents buffer, location + } +; +one_string_constant: +/* Don't concat multiple strings. For asm templates. */ + CST_STRING {intlist_to_string (fst $1) } +; +string_list: + one_string { + let queue = Queue.create () in + Queue.add (fst $1) queue; + queue, snd $1 + } +| string_list one_string { + Queue.add (fst $2) (fst $1); + $1 + } +; + +wstring_list: + CST_WSTRING { $1 } +| wstring_list one_string { (fst $1) @ (fst $2), snd $1 } +| wstring_list CST_WSTRING { (fst $1) @ (fst $2), snd $1 } +/* Only the first string in the list needs an L, so L"a" "b" is the same + * as L"ab" or L"a" L"b". */ + +one_string: + CST_STRING {$1} +| FUNCTION__ {(Cabs.explodeStringToInts + !currentFunctionName), $1} +| PRETTY_FUNCTION__ {(Cabs.explodeStringToInts + !currentFunctionName), $1} +; + +init_expression: + expression { SINGLE_INIT (fst $1) } +| LBRACE initializer_list_opt RBRACE + { COMPOUND_INIT $2} + +initializer_list: /* ISO 6.7.8. Allow a trailing COMMA */ + initializer { [$1] } +| initializer COMMA initializer_list_opt { $1 :: $3 } +; +initializer_list_opt: + /* empty */ { [] } +| initializer_list { $1 } +; +initializer: + init_designators eq_opt init_expression { ($1, $3) } +| gcc_init_designators init_expression { ($1, $2) } +| init_expression { (NEXT_INIT, $1) } +; +eq_opt: + EQ { () } + /*(* GCC allows missing = *)*/ +| /*(* empty *)*/ { () } +; +init_designators: + DOT id_or_typename init_designators_opt { INFIELD_INIT($2, $3) } +| LBRACKET expression RBRACKET init_designators_opt + { ATINDEX_INIT(fst $2, $4) } +| LBRACKET expression ELLIPSIS expression RBRACKET + { ATINDEXRANGE_INIT(fst $2, fst $4) } +; +init_designators_opt: + /* empty */ { NEXT_INIT } +| init_designators { $1 } +; + +gcc_init_designators: /*(* GCC supports these strange things *)*/ + id_or_typename COLON { INFIELD_INIT($1, NEXT_INIT) } +; + +arguments: + /* empty */ { [] } +| comma_expression { fst $1 } +; + +opt_expression: + /* empty */ + {NOTHING} +| comma_expression + {smooth_expression (fst $1)} +; + +comma_expression: + expression {[fst $1], snd $1} +| expression COMMA comma_expression { fst $1 :: fst $3, snd $1 } +| error COMMA comma_expression { $3 } +; + +comma_expression_opt: + /* empty */ { NOTHING } +| comma_expression { smooth_expression (fst $1) } +; + +paren_comma_expression: + LPAREN comma_expression RPAREN { $2 } +| LPAREN error RPAREN { [], $1 } +; + +bracket_comma_expression: + LBRACKET comma_expression RBRACKET { fst $2 } +| LBRACKET error RBRACKET { [] } +; + + +/*** statements ***/ +block: /* ISO 6.8.2 */ + block_begin local_labels block_attrs block_element_list RBRACE + {!Lexerhack.pop_context(); + { blabels = $2; + battrs = $3; + bstmts = $4 }, + $1, $5 + } +| error location RBRACE { { blabels = []; + battrs = []; + bstmts = [] }, + $2, $3 + } +; +block_begin: + LBRACE {!Lexerhack.push_context (); $1} +; + +block_attrs: + /* empty */ { [] } +| BLOCKATTRIBUTE paren_attr_list_ne + { [("__blockattribute__", $2)] } +; + +/* statements and declarations in a block, in any order (for C99 support) */ +block_element_list: + /* empty */ { [] } +| declaration block_element_list { DEFINITION($1) :: $2 } +| statement block_element_list { $1 :: $2 } +/*(* GCC accepts a label at the end of a block *)*/ +| IDENT COLON { [ LABEL (fst $1, NOP (snd $1), + snd $1)] } +| pragma block_element_list { $2 } +; + +local_labels: + /* empty */ { [] } +| LABEL__ local_label_names SEMICOLON local_labels { $2 @ $4 } +; +local_label_names: + IDENT { [ fst $1 ] } +| IDENT COMMA local_label_names { fst $1 :: $3 } +; + + + +statement: + SEMICOLON {NOP ((*handleLoc*) $1) } +| comma_expression SEMICOLON + {COMPUTATION (smooth_expression (fst $1), (*handleLoc*)(snd $1))} +| block {BLOCK (fst3 $1, (*handleLoc*)(snd3 $1))} +| IF paren_comma_expression statement %prec IF + {IF (smooth_expression (fst $2), $3, NOP $1, $1)} +| IF paren_comma_expression statement ELSE statement + {IF (smooth_expression (fst $2), $3, $5, (*handleLoc*) $1)} +| SWITCH paren_comma_expression statement + {SWITCH (smooth_expression (fst $2), $3, (*handleLoc*) $1)} +| WHILE paren_comma_expression statement + {WHILE (smooth_expression (fst $2), $3, (*handleLoc*) $1)} +| DO statement WHILE paren_comma_expression SEMICOLON + {DOWHILE (smooth_expression (fst $4), $2, (*handleLoc*) $1)} +| FOR LPAREN for_clause opt_expression + SEMICOLON opt_expression RPAREN statement + {FOR ($3, $4, $6, $8, (*handleLoc*) $1)} +| IDENT COLON statement + {LABEL (fst $1, $3, (*handleLoc*) (snd $1))} +| CASE expression COLON statement + {CASE (fst $2, $4, (*handleLoc*) $1)} +| CASE expression ELLIPSIS expression COLON statement + {CASERANGE (fst $2, fst $4, $6, (*handleLoc*) $1)} +| DEFAULT COLON + {DEFAULT (NOP $1, (*handleLoc*) $1)} +| RETURN SEMICOLON {RETURN (NOTHING, (*handleLoc*) $1)} +| RETURN comma_expression SEMICOLON + {RETURN (smooth_expression (fst $2), (*handleLoc*) $1)} +| BREAK SEMICOLON {BREAK ((*handleLoc*) $1)} +| CONTINUE SEMICOLON {CONTINUE ((*handleLoc*) $1)} +| GOTO IDENT SEMICOLON + {GOTO (fst $2, (*handleLoc*) $1)} +| GOTO STAR comma_expression SEMICOLON + { COMPGOTO (smooth_expression (fst $3), (*handleLoc*) $1) } +| ASM asmattr LPAREN asmtemplate asmoutputs RPAREN SEMICOLON + { ASM ($2, $4, $5, (*handleLoc*) $1) } +| MSASM { ASM ([], [fst $1], None, (*handleLoc*)(snd $1))} +| TRY block EXCEPT paren_comma_expression block + { let b, _, _ = $2 in + let h, _, _ = $5 in + if not !Cprint.msvcMode then + parse_error "try/except in GCC code"; + TRY_EXCEPT (b, COMMA (fst $4), h, (*handleLoc*) $1) } +| TRY block FINALLY block + { let b, _, _ = $2 in + let h, _, _ = $4 in + if not !Cprint.msvcMode then + parse_error "try/finally in GCC code"; + TRY_FINALLY (b, h, (*handleLoc*) $1) } + +| error location SEMICOLON { (NOP $2)} +; + + +for_clause: + opt_expression SEMICOLON { FC_EXP $1 } +| declaration { FC_DECL $1 } +; + +declaration: /* ISO 6.7.*/ + decl_spec_list init_declarator_list SEMICOLON + { doDeclaration ((*handleLoc*)(snd $1)) (fst $1) $2 } +| decl_spec_list SEMICOLON + { doDeclaration ((*handleLoc*)(snd $1)) (fst $1) [] } +; +init_declarator_list: /* ISO 6.7 */ + init_declarator { [$1] } +| init_declarator COMMA init_declarator_list { $1 :: $3 } + +; +init_declarator: /* ISO 6.7 */ + declarator { ($1, NO_INIT) } +| declarator EQ init_expression + { ($1, $3) } +; + +decl_spec_list: /* ISO 6.7 */ + /* ISO 6.7.1 */ +| TYPEDEF decl_spec_list_opt { SpecTypedef :: $2, $1 } +| EXTERN decl_spec_list_opt { SpecStorage EXTERN :: $2, $1 } +| STATIC decl_spec_list_opt { SpecStorage STATIC :: $2, $1 } +| AUTO decl_spec_list_opt { SpecStorage AUTO :: $2, $1 } +| REGISTER decl_spec_list_opt { SpecStorage REGISTER :: $2, $1} + /* ISO 6.7.2 */ +| type_spec decl_spec_list_opt_no_named { SpecType (fst $1) :: $2, snd $1 } + /* ISO 6.7.4 */ +| INLINE decl_spec_list_opt { SpecInline :: $2, $1 } +| cvspec decl_spec_list_opt { (fst $1) :: $2, snd $1 } +| attribute_nocv decl_spec_list_opt { SpecAttr (fst $1) :: $2, snd $1 } +/* specifier pattern variable (must be last in spec list) */ +| AT_SPECIFIER LPAREN IDENT RPAREN { [ SpecPattern(fst $3) ], $1 } +; +/* (* In most cases if we see a NAMED_TYPE we must shift it. Thus we declare + * NAMED_TYPE to have right associativity *) */ +decl_spec_list_opt: + /* empty */ { [] } %prec NAMED_TYPE +| decl_spec_list { fst $1 } +; +/* (* We add this separate rule to handle the special case when an appearance + * of NAMED_TYPE should not be considered as part of the specifiers but as + * part of the declarator. IDENT has higher precedence than NAMED_TYPE *) + */ +decl_spec_list_opt_no_named: + /* empty */ { [] } %prec IDENT +| decl_spec_list { fst $1 } +; +type_spec: /* ISO 6.7.2 */ + VOID { Tvoid, $1} +| CHAR { Tchar, $1 } +| SHORT { Tshort, $1 } +| INT { Tint, $1 } +| LONG { Tlong, $1 } +| INT64 { Tint64, $1 } +| FLOAT { Tfloat, $1 } +| DOUBLE { Tdouble, $1 } +| SIGNED { Tsigned, $1 } +| UNSIGNED { Tunsigned, $1 } +| STRUCT id_or_typename + { Tstruct ($2, None, []), $1 } +| STRUCT just_attributes id_or_typename + { Tstruct ($3, None, $2), $1 } +| STRUCT id_or_typename LBRACE struct_decl_list RBRACE + { Tstruct ($2, Some $4, []), $1 } +| STRUCT LBRACE struct_decl_list RBRACE + { Tstruct ("", Some $3, []), $1 } +| STRUCT just_attributes id_or_typename LBRACE struct_decl_list RBRACE + { Tstruct ($3, Some $5, $2), $1 } +| STRUCT just_attributes LBRACE struct_decl_list RBRACE + { Tstruct ("", Some $4, $2), $1 } +| UNION id_or_typename + { Tunion ($2, None, []), $1 } +| UNION id_or_typename LBRACE struct_decl_list RBRACE + { Tunion ($2, Some $4, []), $1 } +| UNION LBRACE struct_decl_list RBRACE + { Tunion ("", Some $3, []), $1 } +| UNION just_attributes id_or_typename LBRACE struct_decl_list RBRACE + { Tunion ($3, Some $5, $2), $1 } +| UNION just_attributes LBRACE struct_decl_list RBRACE + { Tunion ("", Some $4, $2), $1 } +| ENUM id_or_typename + { Tenum ($2, None, []), $1 } +| ENUM id_or_typename LBRACE enum_list maybecomma RBRACE + { Tenum ($2, Some $4, []), $1 } +| ENUM LBRACE enum_list maybecomma RBRACE + { Tenum ("", Some $3, []), $1 } +| ENUM just_attributes id_or_typename LBRACE enum_list maybecomma RBRACE + { Tenum ($3, Some $5, $2), $1 } +| ENUM just_attributes LBRACE enum_list maybecomma RBRACE + { Tenum ("", Some $4, $2), $1 } +| NAMED_TYPE { Tnamed (fst $1), snd $1 } +| TYPEOF LPAREN expression RPAREN { TtypeofE (fst $3), $1 } +| TYPEOF LPAREN type_name RPAREN { let s, d = $3 in + TtypeofT (s, d), $1 } +; +struct_decl_list: /* (* ISO 6.7.2. Except that we allow empty structs. We + * also allow missing field names. *) + */ + /* empty */ { [] } +| decl_spec_list SEMICOLON struct_decl_list + { (fst $1, + [(missingFieldDecl, None)]) :: $3 } +/*(* GCC allows extra semicolons *)*/ +| SEMICOLON struct_decl_list + { $2 } +| decl_spec_list field_decl_list SEMICOLON struct_decl_list + { (fst $1, $2) + :: $4 } +/*(* MSVC allows pragmas in strange places *)*/ +| pragma struct_decl_list { $2 } + +| error SEMICOLON struct_decl_list + { $3 } +; +field_decl_list: /* (* ISO 6.7.2 *) */ + field_decl { [$1] } +| field_decl COMMA field_decl_list { $1 :: $3 } +; +field_decl: /* (* ISO 6.7.2. Except that we allow unnamed fields. *) */ +| declarator { ($1, None) } +| declarator COLON expression { ($1, Some (fst $3)) } +| COLON expression { (missingFieldDecl, Some (fst $2)) } +; + +enum_list: /* (* ISO 6.7.2.2 *) */ + enumerator {[$1]} +| enum_list COMMA enumerator {$1 @ [$3]} +| enum_list COMMA error { $1 } +; +enumerator: + IDENT {(fst $1, NOTHING, snd $1)} +| IDENT EQ expression {(fst $1, fst $3, snd $1)} +; + + +declarator: /* (* ISO 6.7.5. Plus Microsoft declarators.*) */ + pointer_opt direct_decl attributes_with_asm + { let (n, decl) = $2 in + (n, applyPointer (fst $1) decl, $3, (*(*handleLoc*)*)(snd $1)) } +; + + +direct_decl: /* (* ISO 6.7.5 *) */ + /* (* We want to be able to redefine named + * types as variable names *) */ +| id_or_typename { ($1, JUSTBASE) } + +| LPAREN attributes declarator RPAREN + { let (n,decl,al,loc) = $3 in + (n, PARENTYPE($2,decl,al)) } + +| direct_decl LBRACKET attributes comma_expression_opt RBRACKET + { let (n, decl) = $1 in + (n, ARRAY(decl, $3, $4)) } +| direct_decl LBRACKET attributes error RBRACKET + { let (n, decl) = $1 in + (n, ARRAY(decl, $3, NOTHING)) } +| direct_decl parameter_list_startscope rest_par_list RPAREN + { let (n, decl) = $1 in + let (params, isva) = $3 in + !Lexerhack.pop_context (); + (n, PROTO(decl, params, isva)) + } +; +parameter_list_startscope: + LPAREN { !Lexerhack.push_context () } +; +rest_par_list: +| /* empty */ { ([], false) } +| parameter_decl rest_par_list1 { let (params, isva) = $2 in + ($1 :: params, isva) + } +; +rest_par_list1: + /* empty */ { ([], false) } +| COMMA ELLIPSIS { ([], true) } +| COMMA parameter_decl rest_par_list1 { let (params, isva) = $3 in + ($2 :: params, isva) + } +; + + +parameter_decl: /* (* ISO 6.7.5 *) */ + decl_spec_list declarator { (fst $1, $2) } +| decl_spec_list abstract_decl { let d, a = $2 in + (fst $1, ("", d, a, cabslu)) } +| decl_spec_list { (fst $1, ("", JUSTBASE, [], cabslu)) } +| LPAREN parameter_decl RPAREN { $2 } +; + +/* (* Old style prototypes. Like a declarator *) */ +old_proto_decl: + pointer_opt direct_old_proto_decl { let (n, decl, a) = $2 in + (n, applyPointer (fst $1) decl, + a, snd $1) + } + +; + +direct_old_proto_decl: + direct_decl LPAREN old_parameter_list_ne RPAREN old_pardef_list + { let par_decl, isva = doOldParDecl $3 $5 in + let n, decl = $1 in + (n, PROTO(decl, par_decl, isva), []) + } +| direct_decl LPAREN RPAREN + { let n, decl = $1 in + (n, PROTO(decl, [], false), []) + } + +/* (* appears sometimesm but generates a shift-reduce conflict. *) +| LPAREN STAR direct_decl LPAREN old_parameter_list_ne RPAREN RPAREN LPAREN RPAREN old_pardef_list + { let par_decl, isva + = doOldParDecl $5 $10 in + let n, decl = $3 in + (n, PROTO(decl, par_decl, isva), []) + } +*/ +; + +old_parameter_list_ne: +| IDENT { [fst $1] } +| IDENT COMMA old_parameter_list_ne { let rest = $3 in + (fst $1 :: rest) } +; + +old_pardef_list: + /* empty */ { ([], false) } +| decl_spec_list old_pardef SEMICOLON ELLIPSIS + { ([(fst $1, $2)], true) } +| decl_spec_list old_pardef SEMICOLON old_pardef_list + { let rest, isva = $4 in + ((fst $1, $2) :: rest, isva) + } +; + +old_pardef: + declarator { [$1] } +| declarator COMMA old_pardef { $1 :: $3 } +| error { [] } +; + + +pointer: /* (* ISO 6.7.5 *) */ + STAR attributes pointer_opt { $2 :: fst $3, $1 } +; +pointer_opt: + /**/ { let l = currentLoc () in + ([], l) } +| pointer { $1 } +; + +type_name: /* (* ISO 6.7.6 *) */ + decl_spec_list abstract_decl { let d, a = $2 in + if a <> [] then begin + parse_error "attributes in type name"; + raise Parsing.Parse_error + end; + (fst $1, d) + } +| decl_spec_list { (fst $1, JUSTBASE) } +; +abstract_decl: /* (* ISO 6.7.6. *) */ + pointer_opt abs_direct_decl attributes { applyPointer (fst $1) $2, $3 } +| pointer { applyPointer (fst $1) JUSTBASE, [] } +; + +abs_direct_decl: /* (* ISO 6.7.6. We do not support optional declarator for + * functions. Plus Microsoft attributes. See the + * discussion for declarator. *) */ +| LPAREN attributes abstract_decl RPAREN + { let d, a = $3 in + PARENTYPE ($2, d, a) + } + +| LPAREN error RPAREN + { JUSTBASE } + +| abs_direct_decl_opt LBRACKET comma_expression_opt RBRACKET + { ARRAY($1, [], $3) } +/*(* The next should be abs_direct_decl_opt but we get conflicts *)*/ +| abs_direct_decl parameter_list_startscope rest_par_list RPAREN + { let (params, isva) = $3 in + !Lexerhack.pop_context (); + PROTO ($1, params, isva) + } +; +abs_direct_decl_opt: + abs_direct_decl { $1 } +| /* empty */ { JUSTBASE } +; +function_def: /* (* ISO 6.9.1 *) */ + function_def_start block + { let (loc, specs, decl) = $1 in + currentFunctionName := "<__FUNCTION__ used outside any functions>"; + !Lexerhack.pop_context (); (* The context pushed by + * announceFunctionName *) + doFunctionDef ((*handleLoc*) loc) (trd3 $2) specs decl (fst3 $2) + } + + +function_def_start: /* (* ISO 6.9.1 *) */ + decl_spec_list declarator + { announceFunctionName $2; + (snd $1, fst $1, $2) + } + +/* (* Old-style function prototype *) */ +| decl_spec_list old_proto_decl + { announceFunctionName $2; + (snd $1, fst $1, $2) + } +/* (* New-style function that does not have a return type *) */ +| IDENT parameter_list_startscope rest_par_list RPAREN + { let (params, isva) = $3 in + let fdec = + (fst $1, PROTO(JUSTBASE, params, isva), [], snd $1) in + announceFunctionName fdec; + (* Default is int type *) + let defSpec = [SpecType Tint] in + (snd $1, defSpec, fdec) + } + +/* (* No return type and old-style parameter list *) */ +| IDENT LPAREN old_parameter_list_ne RPAREN old_pardef_list + { (* Convert pardecl to new style *) + let pardecl, isva = doOldParDecl $3 $5 in + (* Make the function declarator *) + let fdec = (fst $1, + PROTO(JUSTBASE, pardecl,isva), + [], snd $1) in + announceFunctionName fdec; + (* Default is int type *) + let defSpec = [SpecType Tint] in + (snd $1, defSpec, fdec) + } +/* (* No return type and no parameters *) */ +| IDENT LPAREN RPAREN + { (* Make the function declarator *) + let fdec = (fst $1, + PROTO(JUSTBASE, [], false), + [], snd $1) in + announceFunctionName fdec; + (* Default is int type *) + let defSpec = [SpecType Tint] in + (snd $1, defSpec, fdec) + } +; + +/* const/volatile as type specifier elements */ +cvspec: + CONST { SpecCV(CV_CONST), $1 } +| VOLATILE { SpecCV(CV_VOLATILE), $1 } +| RESTRICT { SpecCV(CV_RESTRICT), $1 } +; + +/*** GCC attributes ***/ +attributes: + /* empty */ { []} +| attribute attributes { fst $1 :: $2 } +; + +/* (* In some contexts we can have an inline assembly to specify the name to + * be used for a global. We treat this as a name attribute *) */ +attributes_with_asm: + /* empty */ { [] } +| attribute attributes_with_asm { fst $1 :: $2 } +| ASM LPAREN string_constant RPAREN attributes + { ("__asm__", + [CONSTANT(CONST_STRING (fst $3))]) :: $5 } +; + +/* things like __attribute__, but no const/volatile */ +attribute_nocv: + ATTRIBUTE LPAREN paren_attr_list_ne RPAREN + { ("__attribute__", $3), $1 } +/*(* +| ATTRIBUTE_USED { ("__attribute__", + [ VARIABLE "used" ]), $1 } +*)*/ +| DECLSPEC paren_attr_list_ne { ("__declspec", $2), $1 } +| MSATTR { (fst $1, []), snd $1 } + /* ISO 6.7.3 */ +| THREAD { ("__thread",[]), $1 } +; + +/* __attribute__ plus const/volatile */ +attribute: + attribute_nocv { $1 } +| CONST { ("const", []), $1 } +| RESTRICT { ("restrict",[]), $1 } +| VOLATILE { ("volatile",[]), $1 } +; + +/* (* sm: I need something that just includes __attribute__ and nothing more, + * to support them appearing between the 'struct' keyword and the type name. + * Actually, a declspec can appear there as well (on MSVC) *) */ +just_attribute: + ATTRIBUTE LPAREN paren_attr_list_ne RPAREN + { ("__attribute__", $3) } +| DECLSPEC paren_attr_list_ne { ("__declspec", $2) } +; + +/* this can't be empty, b/c I folded that possibility into the calling + * productions to avoid some S/R conflicts */ +just_attributes: + just_attribute { [$1] } +| just_attribute just_attributes { $1 :: $2 } +; + +/** (* PRAGMAS and ATTRIBUTES *) ***/ +pragma: +| PRAGMA attr PRAGMA_EOL { PRAGMA ($2, $1) } +| PRAGMA attr SEMICOLON PRAGMA_EOL { PRAGMA ($2, $1) } +| PRAGMA_LINE { PRAGMA (VARIABLE (fst $1), + snd $1) } +; + +/* (* We want to allow certain strange things that occur in pragmas, so we + * cannot use directly the language of expressions *) */ +primary_attr: + IDENT { VARIABLE (fst $1) } + /*(* The NAMED_TYPE here creates conflicts with IDENT *)*/ +| NAMED_TYPE { VARIABLE (fst $1) } +| LPAREN attr RPAREN { $2 } +| IDENT IDENT { CALL(VARIABLE (fst $1), [VARIABLE (fst $2)]) } +| CST_INT { CONSTANT(CONST_INT (fst $1)) } +| string_constant { CONSTANT(CONST_STRING (fst $1)) } + /*(* Const when it appears in + * attribute lists, is translated + * to aconst *)*/ +| CONST { VARIABLE "aconst" } +| IDENT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) } + +| CST_INT COLON CST_INT { VARIABLE (fst $1 ^ ":" ^ fst $3) } +| DEFAULT COLON CST_INT { VARIABLE ("default:" ^ fst $3) } + + /*(** GCC allows this as an + * attribute for functions, + * synonim for noreturn **)*/ +| VOLATILE { VARIABLE ("__noreturn__") } +; + +postfix_attr: + primary_attr { $1 } + /* (* use a VARIABLE "" so that the + * parentheses are printed *) */ +| IDENT LPAREN RPAREN { CALL(VARIABLE (fst $1), [VARIABLE ""]) } +| IDENT paren_attr_list_ne { CALL(VARIABLE (fst $1), $2) } + +| postfix_attr ARROW id_or_typename {MEMBEROFPTR ($1, $3)} +| postfix_attr DOT id_or_typename {MEMBEROF ($1, $3)} +; + +/*(* Since in attributes we use both IDENT and NAMED_TYPE as indentifiers, + * that leads to conflicts for SIZEOF and ALIGNOF. In those cases we require + * that their arguments be expressions, not attributes *)*/ +unary_attr: + postfix_attr { $1 } +| SIZEOF unary_expression {EXPR_SIZEOF (fst $2) } +| SIZEOF LPAREN type_name RPAREN + {let b, d = $3 in TYPE_SIZEOF (b, d)} + +| ALIGNOF unary_expression {EXPR_ALIGNOF (fst $2) } +| ALIGNOF LPAREN type_name RPAREN {let b, d = $3 in TYPE_ALIGNOF (b, d)} +| PLUS cast_attr {UNARY (PLUS, $2)} +| MINUS cast_attr {UNARY (MINUS, $2)} +| STAR cast_attr {UNARY (MEMOF, $2)} +| AND cast_attr + {UNARY (ADDROF, $2)} +| EXCLAM cast_attr {UNARY (NOT, $2)} +| TILDE cast_attr {UNARY (BNOT, $2)} +; + +cast_attr: + unary_attr { $1 } +; + +multiplicative_attr: + cast_attr { $1 } +| multiplicative_attr STAR cast_attr {BINARY(MUL ,$1 , $3)} +| multiplicative_attr SLASH cast_attr {BINARY(DIV ,$1 , $3)} +| multiplicative_attr PERCENT cast_attr {BINARY(MOD ,$1 , $3)} +; + + +additive_attr: + multiplicative_attr { $1 } +| additive_attr PLUS multiplicative_attr {BINARY(ADD ,$1 , $3)} +| additive_attr MINUS multiplicative_attr {BINARY(SUB ,$1 , $3)} +; + +shift_attr: + additive_attr { $1 } +| shift_attr INF_INF additive_attr {BINARY(SHL ,$1 , $3)} +| shift_attr SUP_SUP additive_attr {BINARY(SHR ,$1 , $3)} +; + +relational_attr: + shift_attr { $1 } +| relational_attr INF shift_attr {BINARY(LT ,$1 , $3)} +| relational_attr SUP shift_attr {BINARY(GT ,$1 , $3)} +| relational_attr INF_EQ shift_attr {BINARY(LE ,$1 , $3)} +| relational_attr SUP_EQ shift_attr {BINARY(GE ,$1 , $3)} +; + +equality_attr: + relational_attr { $1 } +| equality_attr EQ_EQ relational_attr {BINARY(EQ ,$1 , $3)} +| equality_attr EXCLAM_EQ relational_attr {BINARY(NE ,$1 , $3)} +; + + +bitwise_and_attr: + equality_attr { $1 } +| bitwise_and_attr AND equality_attr {BINARY(BAND ,$1 , $3)} +; + +bitwise_xor_attr: + bitwise_and_attr { $1 } +| bitwise_xor_attr CIRC bitwise_and_attr {BINARY(XOR ,$1 , $3)} +; + +bitwise_or_attr: + bitwise_xor_attr { $1 } +| bitwise_or_attr PIPE bitwise_xor_attr {BINARY(BOR ,$1 , $3)} +; + +logical_and_attr: + bitwise_or_attr { $1 } +| logical_and_attr AND_AND bitwise_or_attr {BINARY(AND ,$1 , $3)} +; + +logical_or_attr: + logical_and_attr { $1 } +| logical_or_attr PIPE_PIPE logical_and_attr {BINARY(OR ,$1 , $3)} +; + + +attr: logical_or_attr { $1 } +; + +attr_list_ne: +| attr { [$1] } +| attr COMMA attr_list_ne { $1 :: $3 } +| error COMMA attr_list_ne { $3 } +; +paren_attr_list_ne: + LPAREN attr_list_ne RPAREN { $2 } +| LPAREN error RPAREN { [] } +; +/*** GCC ASM instructions ***/ +asmattr: + /* empty */ { [] } +| VOLATILE asmattr { ("volatile", []) :: $2 } +| CONST asmattr { ("const", []) :: $2 } +; +asmtemplate: + one_string_constant { [$1] } +| one_string_constant asmtemplate { $1 :: $2 } +; +asmoutputs: + /* empty */ { None } +| COLON asmoperands asminputs + { let (ins, clobs) = $3 in + Some {aoutputs = $2; ainputs = ins; aclobbers = clobs} } +; +asmoperands: + /* empty */ { [] } +| asmoperandsne { List.rev $1 } +; +asmoperandsne: + asmoperand { [$1] } +| asmoperandsne COMMA asmoperand { $3 :: $1 } +; +asmoperand: + string_constant LPAREN expression RPAREN { (fst $1, fst $3) } +| string_constant LPAREN error RPAREN { (fst $1, NOTHING ) } +; +asminputs: + /* empty */ { ([], []) } +| COLON asmoperands asmclobber + { ($2, $3) } +; +asmclobber: + /* empty */ { [] } +| COLON asmcloberlst_ne { $2 } +; +asmcloberlst_ne: + one_string_constant { [$1] } +| one_string_constant COMMA asmcloberlst_ne { $1 :: $3 } +; + +%% + + + diff --git a/cil/src/frontc/cprint.ml b/cil/src/frontc/cprint.ml new file mode 100644 index 0000000..570945c --- /dev/null +++ b/cil/src/frontc/cprint.ml @@ -0,0 +1,1014 @@ +(* + * + * Copyright (c) 2001-2003, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Ben Liblit + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) +(* cprint -- pretty printer of C program from abstract syntax +** +** Project: FrontC +** File: cprint.ml +** Version: 2.1e +** Date: 9.1.99 +** Author: Hugues Cassé +** +** 1.0 2.22.99 Hugues Cassé First version. +** 2.0 3.18.99 Hugues Cassé Compatible with Frontc 2.1, use of CAML +** pretty printer. +** 2.1 3.22.99 Hugues Cassé More efficient custom pretty printer used. +** 2.1a 4.12.99 Hugues Cassé Correctly handle: +** char *m, *m, *p; m + (n - p) +** 2.1b 4.15.99 Hugues Cassé x + (y + z) stays x + (y + z) for +** keeping computation order. +** 2.1c 7.23.99 Hugues Cassé Improvement of case and default display. +** 2.1d 8.25.99 Hugues Cassé Rebuild escape sequences in string and +** characters. +** 2.1e 9.1.99 Hugues Cassé Fix, recognize and correctly display '\0'. +*) + +(* George Necula: I changed this pretty dramatically since CABS changed *) +open Cabs +open Escape +let version = "Cprint 2.1e 9.1.99 Hugues Cassé" + +type loc = { line : int; file : string } + +let lu = {line = -1; file = "loc unknown";} +let cabslu = {lineno = -10; + filename = "cabs loc unknown"; + byteno = -10;} + +let curLoc = ref cabslu + +let msvcMode = ref false + +let printLn = ref true +let printLnComment = ref false + +let printCounters = ref false +let printComments = ref false + +(* +** FrontC Pretty printer +*) +let out = ref stdout +let width = ref 80 +let tab = ref 2 +let max_indent = ref 60 + +let line = ref "" +let line_len = ref 0 +let current = ref "" +let current_len = ref 0 +let spaces = ref 0 +let follow = ref 0 +let roll = ref 0 + +let print_tab size = + for i = 1 to size / 8 do + output_char !out '\t' + done; + for i = 1 to size mod 8 do + output_char !out ' ' + done + +let flush _ = + if !line <> "" then begin + print_tab (!spaces + !follow); + output_string !out !line; + line := ""; + line_len := 0 + end + +let commit _ = + if !current <> "" then begin + if !line = "" then begin + line := !current; + line_len := !current_len + end else begin + line := (!line ^ " " ^ !current); + line_len := !line_len + 1 + !current_len + end; + current := ""; + current_len := 0 + end + + +let addline () = + curLoc := {lineno = !curLoc.lineno+1; + filename = !curLoc.filename; + byteno = -1;} (*sfg: can we do better than this?*) + + +let new_line _ = + commit (); + if !line <> "" then begin + flush (); + addline(); + output_char !out '\n' + end; + follow := 0 + +let force_new_line _ = + commit (); + flush (); + addline(); + output_char !out '\n'; + follow := 0 + +let indent _ = + new_line (); + spaces := !spaces + !tab; + if !spaces >= !max_indent then begin + spaces := !tab; + roll := !roll + 1 + end + +let indentline _ = + new_line (); + if !spaces >= !max_indent then begin + spaces := !tab; + roll := !roll + 1 + end + +let unindent _ = + new_line (); + spaces := !spaces - !tab; + if (!spaces <= 0) && (!roll > 0) then begin + spaces := ((!max_indent - 1) / !tab) * !tab; + roll := !roll - 1 + end + +let space _ = commit () + +let print str = + current := !current ^ str; + current_len := !current_len + (String.length str); + if (!spaces + !follow + !line_len + 1 + !current_len) > !width + then begin + if !line_len = 0 then commit (); + flush (); + addline(); + output_char !out '\n'; + if !follow = 0 then follow := !tab + end + +(* sm: for some reason I couldn't just call print from frontc.... ? *) +let print_unescaped_string str = print str + +let setLoc (l : cabsloc) = + if !printLn then + if (l.lineno <> !curLoc.lineno) || l.filename <> !curLoc.filename then + begin + let oldspaces = !spaces in + (* sm: below, we had '//#' instead of '#', which means printLnComment was disregarded *) + if !printLnComment then print "//" else print "#"; + if !msvcMode then print "line"; + print " "; + print (string_of_int l.lineno); + if (l.filename <> !curLoc.filename) then begin + print (" \"" ^ l.filename ^ "\"") + end; + spaces := oldspaces; + new_line(); + curLoc := l + end + + + +(* +** Useful primitives +*) +let print_list print_sep print_elt lst = + let _ = List.fold_left + (fun com elt -> + if com then print_sep (); + print_elt elt; + true) + false + lst in + () + +let print_commas nl fct lst = + print_list (fun () -> print ","; if nl then new_line() else space()) fct lst + +let print_string (s:string) = + print ("\"" ^ escape_string s ^ "\"") + +let print_wstring (s: int64 list ) = + print ("L\"" ^ escape_wstring s ^ "\"") + +(* +** Base Type Printing +*) + +let rec print_specifiers (specs: spec_elem list) = + comprint "specifier("; + let print_spec_elem = function + SpecTypedef -> print "typedef " + | SpecInline -> print "__inline " + | SpecStorage sto -> + print (match sto with + NO_STORAGE -> (comstring "/*no storage*/") + | AUTO -> "auto " + | STATIC -> "static " + | EXTERN -> "extern " + | REGISTER -> "register ") + | SpecCV cv -> + print (match cv with + | CV_CONST -> "const " + | CV_VOLATILE -> "volatile " + | CV_RESTRICT -> "restrict ") + | SpecAttr al -> print_attribute al; space () + | SpecType bt -> print_type_spec bt + | SpecPattern name -> print ("@specifier(" ^ name ^ ") ") + in + List.iter print_spec_elem specs + ;comprint ")" + + +and print_type_spec = function + Tvoid -> print "void " + | Tchar -> print "char " + | Tshort -> print "short " + | Tint -> print "int " + | Tlong -> print "long " + | Tint64 -> print "__int64 " + | Tfloat -> print "float " + | Tdouble -> print "double " + | Tsigned -> print "signed " + | Tunsigned -> print "unsigned " + | Tnamed s -> comprint "tnamed"; print s; space (); + | Tstruct (n, None, _) -> print ("struct " ^ n ^ " ") + | Tstruct (n, Some flds, extraAttrs) -> + (print_struct_name_attr "struct" n extraAttrs); + (print_fields flds) + | Tunion (n, None, _) -> print ("union " ^ n ^ " ") + | Tunion (n, Some flds, extraAttrs) -> + (print_struct_name_attr "union" n extraAttrs); + (print_fields flds) + | Tenum (n, None, _) -> print ("enum " ^ n ^ " ") + | Tenum (n, Some enum_items, extraAttrs) -> + (print_struct_name_attr "enum" n extraAttrs); + (print_enum_items enum_items) + | TtypeofE e -> print "__typeof__("; print_expression e; print ") " + | TtypeofT (s,d) -> print "__typeof__("; print_onlytype (s, d); print ") " + + +(* print "struct foo", but with specified keyword and a list of + * attributes to put between keyword and name *) +and print_struct_name_attr (keyword: string) (name: string) (extraAttrs: attribute list) = +begin + if extraAttrs = [] then + print (keyword ^ " " ^ name) + else begin + (print (keyword ^ " ")); + (print_attributes extraAttrs); (* prints a final space *) + (print name); + end +end + + +(* This is the main printer for declarations. It is easy bacause the + * declarations are laid out as they need to be printed. *) +and print_decl (n: string) = function + JUSTBASE -> if n <> "___missing_field_name" then + print n + else + comprint "missing field name" + | PARENTYPE (al1, d, al2) -> + print "("; + print_attributes al1; space (); + print_decl n d; space (); + print_attributes al2; print ")" + | PTR (al, d) -> + print "* "; + print_attributes al; space (); + print_decl n d + | ARRAY (d, al, e) -> + print_decl n d; + print "["; + print_attributes al; + if e <> NOTHING then print_expression e; + print "]" + | PROTO(d, args, isva) -> + comprint "proto("; + print_decl n d; + print "("; + print_params args isva; + print ")"; + comprint ")" + + +and print_fields (flds : field_group list) = + if flds = [] then print " { } " + else begin + print " {"; + indent (); + List.iter + (fun fld -> print_field_group fld; print ";"; new_line ()) + flds; + unindent (); + print "} " + end + +and print_enum_items items = + if items = [] then print " { } " + else begin + print " {"; + indent (); + print_commas + true + (fun (id, exp, loc) -> print id; + if exp = NOTHING then () + else begin + space (); + print "= "; + print_expression exp + end) + items; + unindent (); + print "} "; + end + + +and print_onlytype (specs, dt) = + print_specifiers specs; + print_decl "" dt + +and print_name ((n, decl, attrs, _) : name) = + print_decl n decl; + space (); + print_attributes attrs + +and print_init_name ((n, i) : init_name) = + print_name n; + if i <> NO_INIT then begin + space (); + print "= "; + print_init_expression i + end + +and print_name_group (specs, names) = + print_specifiers specs; + print_commas false print_name names + +and print_field_group (specs, fields) = + print_specifiers specs; + print_commas false print_field fields + + +and print_field (name, widtho) = + print_name name; + (match widtho with + None -> () + | Some w -> print " : "; print_expression w) + +and print_init_name_group (specs, names) = + print_specifiers specs; + print_commas false print_init_name names + +and print_single_name (specs, name) = + print_specifiers specs; + print_name name + +and print_params (pars : single_name list) (ell : bool) = + print_commas false print_single_name pars; + if ell then print (if pars = [] then "..." else ", ...") else () + +and print_old_params pars ell = + print_commas false (fun id -> print id) pars; + if ell then print (if pars = [] then "..." else ", ...") else () + + +(* +** Expression printing +** Priorities +** 16 variables +** 15 . -> [] call() +** 14 ++, -- (post) +** 13 ++ -- (pre) ~ ! - + & *(cast) +** 12 * / % +** 11 + - +** 10 << >> +** 9 < <= > >= +** 8 == != +** 7 & +** 6 ^ +** 5 | +** 4 && +** 3 || +** 2 ? : +** 1 = ?= +** 0 , +*) +and get_operator exp = + match exp with + NOTHING -> ("", 16) + | UNARY (op, _) -> + (match op with + MINUS -> ("-", 13) + | PLUS -> ("+", 13) + | NOT -> ("!", 13) + | BNOT -> ("~", 13) + | MEMOF -> ("*", 13) + | ADDROF -> ("&", 13) + | PREINCR -> ("++", 13) + | PREDECR -> ("--", 13) + | POSINCR -> ("++", 14) + | POSDECR -> ("--", 14)) + | LABELADDR s -> ("", 16) (* Like a constant *) + | BINARY (op, _, _) -> + (match op with + MUL -> ("*", 12) + | DIV -> ("/", 12) + | MOD -> ("%", 12) + | ADD -> ("+", 11) + | SUB -> ("-", 11) + | SHL -> ("<<", 10) + | SHR -> (">>", 10) + | LT -> ("<", 9) + | LE -> ("<=", 9) + | GT -> (">", 9) + | GE -> (">=", 9) + | EQ -> ("==", 8) + | NE -> ("!=", 8) + | BAND -> ("&", 7) + | XOR -> ("^", 6) + | BOR -> ("|", 5) + | AND -> ("&&", 4) + | OR -> ("||", 3) + | ASSIGN -> ("=", 1) + | ADD_ASSIGN -> ("+=", 1) + | SUB_ASSIGN -> ("-=", 1) + | MUL_ASSIGN -> ("*=", 1) + | DIV_ASSIGN -> ("/=", 1) + | MOD_ASSIGN -> ("%=", 1) + | BAND_ASSIGN -> ("&=", 1) + | BOR_ASSIGN -> ("|=", 1) + | XOR_ASSIGN -> ("^=", 1) + | SHL_ASSIGN -> ("<<=", 1) + | SHR_ASSIGN -> (">>=", 1)) + | QUESTION _ -> ("", 2) + | CAST _ -> ("", 13) + | CALL _ -> ("", 15) + | COMMA _ -> ("", 0) + | CONSTANT _ -> ("", 16) + | VARIABLE name -> ("", 16) + | EXPR_SIZEOF exp -> ("", 16) + | TYPE_SIZEOF _ -> ("", 16) + | EXPR_ALIGNOF exp -> ("", 16) + | TYPE_ALIGNOF _ -> ("", 16) + | INDEX (exp, idx) -> ("", 15) + | MEMBEROF (exp, fld) -> ("", 15) + | MEMBEROFPTR (exp, fld) -> ("", 15) + | GNU_BODY _ -> ("", 17) + | EXPR_PATTERN _ -> ("", 16) (* sm: not sure about this *) + +and print_comma_exps exps = + print_commas false print_expression exps + +and print_init_expression (iexp: init_expression) : unit = + match iexp with + NO_INIT -> () + | SINGLE_INIT e -> print_expression e + | COMPOUND_INIT initexps -> + let doinitexp = function + NEXT_INIT, e -> print_init_expression e + | i, e -> + let rec doinit = function + NEXT_INIT -> () + | INFIELD_INIT (fn, i) -> print ("." ^ fn); doinit i + | ATINDEX_INIT (e, i) -> + print "["; + print_expression e; + print "]"; + doinit i + | ATINDEXRANGE_INIT (s, e) -> + print "["; + print_expression s; + print " ... "; + print_expression e; + print "]" + in + doinit i; print " = "; + print_init_expression e + in + print "{"; + print_commas false doinitexp initexps; + print "}" + +and print_expression (exp: expression) = print_expression_level 1 exp + +and print_expression_level (lvl: int) (exp : expression) = + let (txt, lvl') = get_operator exp in + let _ = if lvl > lvl' then print "(" else () in + let _ = match exp with + NOTHING -> () + | UNARY (op, exp') -> + (match op with + POSINCR | POSDECR -> + print_expression_level lvl' exp'; + print txt + | _ -> + print txt; space (); (* Print the space to avoid --5 *) + print_expression_level lvl' exp') + | LABELADDR l -> print ("&& " ^ l) + | BINARY (op, exp1, exp2) -> + (*if (op = SUB) && (lvl <= lvl') then print "(";*) + print_expression_level lvl' exp1; + space (); + print txt; + space (); + (*print_expression exp2 (if op = SUB then (lvl' + 1) else lvl');*) + print_expression_level (lvl' + 1) exp2 + (*if (op = SUB) && (lvl <= lvl') then print ")"*) + | QUESTION (exp1, exp2, exp3) -> + print_expression_level 2 exp1; + space (); + print "? "; + print_expression_level 2 exp2; + space (); + print ": "; + print_expression_level 2 exp3; + | CAST (typ, iexp) -> + print "("; + print_onlytype typ; + print ")"; + (* Always print parentheses. In a small number of cases when we print + * constants we don't need them *) + (match iexp with + SINGLE_INIT e -> print_expression_level 15 e + | COMPOUND_INIT _ -> (* print "("; *) + print_init_expression iexp + (* ; print ")" *) + | NO_INIT -> print "") + + | CALL (VARIABLE "__builtin_va_arg", [arg; TYPE_SIZEOF (bt, dt)]) -> + comprint "variable"; + print "__builtin_va_arg"; + print "("; + print_expression_level 1 arg; + print ","; + print_onlytype (bt, dt); + print ")" + | CALL (exp, args) -> + print_expression_level 16 exp; + print "("; + print_comma_exps args; + print ")" + | COMMA exps -> + print_comma_exps exps + | CONSTANT cst -> + (match cst with + CONST_INT i -> print i + | CONST_FLOAT r -> print r + | CONST_CHAR c -> print ("'" ^ escape_wstring c ^ "'") + | CONST_WCHAR c -> print ("L'" ^ escape_wstring c ^ "'") + | CONST_STRING s -> print_string s + | CONST_WSTRING ws -> print_wstring ws) + | VARIABLE name -> + comprint "variable"; + print name + | EXPR_SIZEOF exp -> + print "sizeof("; + print_expression_level 0 exp; + print ")" + | TYPE_SIZEOF (bt,dt) -> + print "sizeof("; + print_onlytype (bt, dt); + print ")" + | EXPR_ALIGNOF exp -> + print "__alignof__("; + print_expression_level 0 exp; + print ")" + | TYPE_ALIGNOF (bt,dt) -> + print "__alignof__("; + print_onlytype (bt, dt); + print ")" + | INDEX (exp, idx) -> + print_expression_level 16 exp; + print "["; + print_expression_level 0 idx; + print "]" + | MEMBEROF (exp, fld) -> + print_expression_level 16 exp; + print ("." ^ fld) + | MEMBEROFPTR (exp, fld) -> + print_expression_level 16 exp; + print ("->" ^ fld) + | GNU_BODY (blk) -> + print "("; + print_block blk; + print ")" + | EXPR_PATTERN (name) -> + print ("@expr(" ^ name ^ ") ") + in + if lvl > lvl' then print ")" else () + + +(* +** Statement printing +*) +and print_statement stat = + match stat with + NOP (loc) -> + setLoc(loc); + print ";"; + new_line () + | COMPUTATION (exp, loc) -> + setLoc(loc); + print_expression exp; + print ";"; + new_line () + | BLOCK (blk, loc) -> print_block blk + + | SEQUENCE (s1, s2, loc) -> + setLoc(loc); + print_statement s1; + print_statement s2; + | IF (exp, s1, s2, loc) -> + setLoc(loc); + print "if("; + print_expression_level 0 exp; + print ")"; + print_substatement s1; + (match s2 with + | NOP(_) -> () + | _ -> begin + print "else"; + print_substatement s2; + end) + | WHILE (exp, stat, loc) -> + setLoc(loc); + print "while("; + print_expression_level 0 exp; + print ")"; + print_substatement stat + | DOWHILE (exp, stat, loc) -> + setLoc(loc); + print "do"; + print_substatement stat; + print "while("; + print_expression_level 0 exp; + print ");"; + new_line (); + | FOR (fc1, exp2, exp3, stat, loc) -> + setLoc(loc); + print "for("; + (match fc1 with + FC_EXP exp1 -> print_expression_level 0 exp1; print ";" + | FC_DECL dec1 -> print_def dec1); + space (); + print_expression_level 0 exp2; + print ";"; + space (); + print_expression_level 0 exp3; + print ")"; + print_substatement stat + | BREAK (loc)-> + setLoc(loc); + print "break;"; new_line () + | CONTINUE (loc) -> + setLoc(loc); + print "continue;"; new_line () + | RETURN (exp, loc) -> + setLoc(loc); + print "return"; + if exp = NOTHING + then () + else begin + print " "; + print_expression_level 1 exp + end; + print ";"; + new_line () + | SWITCH (exp, stat, loc) -> + setLoc(loc); + print "switch("; + print_expression_level 0 exp; + print ")"; + print_substatement stat + | CASE (exp, stat, loc) -> + setLoc(loc); + unindent (); + print "case "; + print_expression_level 1 exp; + print ":"; + indent (); + print_substatement stat + | CASERANGE (expl, exph, stat, loc) -> + setLoc(loc); + unindent (); + print "case "; + print_expression expl; + print " ... "; + print_expression exph; + print ":"; + indent (); + print_substatement stat + | DEFAULT (stat, loc) -> + setLoc(loc); + unindent (); + print "default :"; + indent (); + print_substatement stat + | LABEL (name, stat, loc) -> + setLoc(loc); + print (name ^ ":"); + space (); + print_substatement stat + | GOTO (name, loc) -> + setLoc(loc); + print ("goto " ^ name ^ ";"); + new_line () + | COMPGOTO (exp, loc) -> + setLoc(loc); + print ("goto *"); print_expression exp; print ";"; new_line () + | DEFINITION d -> + print_def d + | ASM (attrs, tlist, details, loc) -> + setLoc(loc); + let print_asm_operand (cnstr, e) = + print_string cnstr; space (); print_expression_level 100 e + in + if !msvcMode then begin + print "__asm {"; + print_list (fun () -> new_line()) print tlist; (* templates *) + print "};" + end else begin + print "__asm__ "; + print_attributes attrs; + print "("; + print_list (fun () -> new_line()) print_string tlist; (* templates *) + begin + match details with + | None -> () + | Some { aoutputs = outs; ainputs = ins; aclobbers = clobs } -> + print ":"; space (); + print_commas false print_asm_operand outs; + if ins <> [] || clobs <> [] then begin + print ":"; space (); + print_commas false print_asm_operand ins; + if clobs <> [] then begin + print ":"; space (); + print_commas false print_string clobs + end; + end + end; + print ");" + end; + new_line () + | TRY_FINALLY (b, h, loc) -> + setLoc loc; + print "__try "; + print_block b; + print "__finally "; + print_block h + + | TRY_EXCEPT (b, e, h, loc) -> + setLoc loc; + print "__try "; + print_block b; + print "__except("; print_expression e; print ")"; + print_block h + +and print_block blk = + new_line(); + print "{"; + indent (); + if blk.blabels <> [] then begin + print "__label__ "; + print_commas false print blk.blabels; + print ";"; + new_line (); + end; + if blk.battrs <> [] then begin + List.iter print_attribute blk.battrs; + new_line (); + end; + List.iter print_statement blk.bstmts; + unindent (); + print "}"; + new_line () + +and print_substatement stat = + match stat with + IF _ + | SEQUENCE _ + | DOWHILE _ -> + new_line (); + print "{"; + indent (); + print_statement stat; + unindent (); + print "}"; + new_line (); + | BLOCK _ -> + print_statement stat + | _ -> + indent (); + print_statement stat; + unindent () + + +(* +** GCC Attributes +*) +and print_attribute (name,args) = + if args = [] then print ( + match name with + "restrict" -> "__restrict" + (* weimer: Fri Dec 7 17:12:35 2001 + * must not print 'restrict' and the code below does allows some + * plain 'restrict's to slip though! *) + | x -> x) + else begin + print name; + print "("; if name = "__attribute__" then print "("; + (match args with + [VARIABLE "aconst"] -> print "const" + | [VARIABLE "restrict"] -> print "__restrict" + | _ -> print_commas false (fun e -> print_expression e) args); + print ")"; if name = "__attribute__" then print ")" + end + +(* Print attributes. *) +and print_attributes attrs = + List.iter (fun a -> print_attribute a; space ()) attrs + +(* +** Declaration printing +*) +and print_defs defs = + let prev = ref false in + List.iter + (fun def -> + (match def with + DECDEF _ -> prev := false + | _ -> + if not !prev then force_new_line (); + prev := true); + print_def def) + defs + +and print_def def = + match def with + FUNDEF (proto, body, loc, _) -> + comprint "fundef"; + if !printCounters then begin + try + let fname = + match proto with + (_, (n, _, _, _)) -> n + in + print_def (DECDEF (([SpecType Tint], + [(fname ^ "__counter", JUSTBASE, [], cabslu), + NO_INIT]), loc)); + with Not_found -> print "/* can't print the counter */" + end; + setLoc(loc); + print_single_name proto; + print_block body; + force_new_line (); + + | DECDEF (names, loc) -> + comprint "decdef"; + setLoc(loc); + print_init_name_group names; + print ";"; + new_line () + + | TYPEDEF (names, loc) -> + comprint "typedef"; + setLoc(loc); + print_name_group names; + print ";"; + new_line (); + force_new_line () + + | ONLYTYPEDEF (specs, loc) -> + comprint "onlytypedef"; + setLoc(loc); + print_specifiers specs; + print ";"; + new_line (); + force_new_line () + + | GLOBASM (asm, loc) -> + setLoc(loc); + print "__asm__ ("; print_string asm; print ");"; + new_line (); + force_new_line () + + | PRAGMA (a,loc) -> + setLoc(loc); + force_new_line (); + print "#pragma "; + let oldwidth = !width in + width := 1000000; (* Do not wrap pragmas *) + print_expression a; + width := oldwidth; + force_new_line () + + | LINKAGE (n, loc, dl) -> + setLoc (loc); + force_new_line (); + print "extern "; print_string n; print_string " {"; + List.iter print_def dl; + print_string "}"; + force_new_line () + + | TRANSFORMER(srcdef, destdeflist, loc) -> + setLoc(loc); + print "@transform {"; + force_new_line(); + print "{"; + force_new_line(); + indent (); + print_def srcdef; + unindent(); + print "}"; + force_new_line(); + print "to {"; + force_new_line(); + indent(); + List.iter print_def destdeflist; + unindent(); + print "}"; + force_new_line() + + | EXPRTRANSFORMER(srcexpr, destexpr, loc) -> + setLoc(loc); + print "@transformExpr { "; + print_expression srcexpr; + print " } to { "; + print_expression destexpr; + print " }"; + force_new_line() + + +(* sm: print a comment if the printComments flag is set *) +and comprint (str : string) : unit = +begin + if (!printComments) then ( + print "/*"; + print str; + print "*/ " + ) + else + () +end + +(* sm: yield either the given string, or "", depending on printComments *) +and comstring (str : string) : string = +begin + if (!printComments) then + str + else + "" +end + + +(* print abstrac_syntax -> () +** Pretty printing the given abstract syntax program. +*) +let printFile (result : out_channel) ((fname, defs) : file) = + out := result; + print_defs defs; + flush () (* sm: should do this here *) + +let set_tab t = tab := t +let set_width w = width := w + diff --git a/cil/src/frontc/frontc.ml b/cil/src/frontc/frontc.ml new file mode 100644 index 0000000..459ae2c --- /dev/null +++ b/cil/src/frontc/frontc.ml @@ -0,0 +1,256 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + +module E = Errormsg +open Trace +open Pretty + +(* Output management *) +let out : out_channel option ref = ref None +let close_me = ref false + +let close_output _ = + match !out with + None -> () + | Some o -> begin + flush o; + if !close_me then close_out o else (); + close_me := false + end + +let set_output filename = + close_output (); + (try out := Some (open_out filename) + with (Sys_error msg) -> + output_string stderr ("Error while opening output: " ^ msg); exit 1); + close_me := true + + (* Signal that we are in MS VC mode *) +let setMSVCMode () = + Cprint.msvcMode := true + +(* filename for patching *) +let patchFileName : string ref = ref "" (* by default do no patching *) + +(* patching file contents *) +let patchFile : Cabs.file option ref = ref None + +(* whether to print the patched CABS files *) +let printPatchedFiles : bool ref = ref false + +(* whether to print a file of prototypes after parsing *) +let doPrintProtos : bool ref = ref false + +(* this seems like something that should be built-in.. *) +let isNone (o : 'a option) : bool = +begin + match o with + | Some _ -> false + | None -> true +end + +(* +** Argument definition +*) +let args : (string * Arg.spec * string) list = +[ + "--cabsonly", Arg.String set_output, ": CABS output file name"; + "--printComments", Arg.Unit (fun _ -> Cprint.printComments := true), + ": print cabs tree structure in comments in cabs output"; + "--patchFile", Arg.String (fun pf -> patchFileName := pf), + ": name the file containing patching transformations"; + "--printPatched", Arg.Unit (fun _ -> printPatchedFiles := true), + ": print patched CABS files after patching, to *.patched"; + "--printProtos", Arg.Unit (fun _ -> doPrintProtos := true), + ": print prototypes to safec.proto.h after parsing"; +] + +exception ParseError of string +exception CabsOnly + +(* parse, and apply patching *) +let rec parse_to_cabs fname = +begin + (* parse the patch file if it isn't parsed already *) + if ((!patchFileName <> "") && (isNone !patchFile)) then ( + (* parse the patch file *) + patchFile := Some(parse_to_cabs_inner !patchFileName); + if !E.hadErrors then + (failwith "There were parsing errors in the patch file") + ); + + (* now parse the file we came here to parse *) + let cabs = parse_to_cabs_inner fname in + if !E.hadErrors then + E.s (E.error "There were parsing errors in %s\n" fname); + + (* and apply the patch file, return transformed file *) + let patched = match !patchFile with + + | Some(pf) -> ( + (* save old value of out so I can use it for debugging during patching *) + let oldOut = !out in + + (* reset out so we don't try to print the patch file to it *) + out := None; + + (trace "patch" (dprintf "newpatching %s\n" fname)); + let result = (Stats.time "newpatch" (Patch.applyPatch pf) cabs) in + + if (!printPatchedFiles) then begin + let outFname:string = fname ^ ".patched" in + (trace "patch" (dprintf "printing patched version of %s to %s\n" + fname outFname)); + let o = (open_out outFname) in + (Cprint.printFile o result); + (close_out o) + end; + + (* restore out *) + Cprint.flush (); + out := oldOut; + + result + ) + | None -> cabs + in + + (* print it ... *) + (match !out with + Some o -> begin + (trace "sm" (dprintf "writing the cabs output\n")); + output_string o ("/* Generated by Frontc */\n"); + Stats.time "printCABS" (Cprint.printFile o) patched; + close_output (); + raise CabsOnly + end + | None -> ()); + if !E.hadErrors then + raise Parsing.Parse_error; + + (* and return the patched source *) + patched +end + + +(* just parse *) +and parse_to_cabs_inner (fname : string) = + try + if !E.verboseFlag then ignore (E.log "Frontc is parsing %s\n" fname); + flush !E.logChannel; + E.hadErrors := false; + let lexbuf = Clexer.init fname in + let cabs = Stats.time "parse" (Cparser.file Clexer.initial) lexbuf in + Clexer.finish (); + (fname, cabs) + with (Sys_error msg) -> begin + ignore (E.log "Cannot open %s : %s\n" fname msg); + Clexer.finish (); + close_output (); + raise (ParseError("Cannot open " ^ fname ^ ": " ^ msg ^ "\n")) + end + | Parsing.Parse_error -> begin + ignore (E.log "Parsing error\n"); + Clexer.finish (); + close_output (); + raise (ParseError("Parse error")) + end + | e -> begin + ignore (E.log "Caught %s while parsing\n" (Printexc.to_string e)); + Clexer.finish (); + raise e + end + + +(* print to safec.proto.h the prototypes of all functions that are defined *) +let printPrototypes ((fname, file) : Cabs.file) : unit = +begin + (*ignore (E.log "file has %d defns\n" (List.length file));*) + + let chan = open_out "safec.proto.h" in + ignore (fprintf chan "/* generated prototypes file, %d defs */\n" (List.length file)); + Cprint.out := chan; + + let counter : int ref = ref 0 in + + let rec loop (d : Cabs.definition) = begin + match d with + | Cabs.FUNDEF(name, _, loc, _) -> ( + match name with + | (_, (funcname, Cabs.PROTO(_,_,_), _, _)) -> ( + incr counter; + ignore (fprintf chan "\n/* %s from %s:%d */\n" + funcname loc.Cabs.filename loc.Cabs.lineno); + flush chan; + Cprint.print_single_name name; + Cprint.print_unescaped_string ";"; + Cprint.force_new_line (); + Cprint.flush () + ) + | _ -> () + ) + + | _ -> () + end in + (List.iter loop file); + + ignore (fprintf chan "\n/* wrote %d prototypes */\n" !counter); + close_out chan; + ignore (E.log "printed %d prototypes from %d defns to safec.proto.h\n" + !counter (List.length file)) +end + + + +let parse fname = + (trace "sm" (dprintf "parsing %s to Cabs\n" fname)); + let cabs = parse_to_cabs fname in + (* Now (return a function that will) convert to CIL *) + fun _ -> + (trace "sm" (dprintf "converting %s from Cabs to CIL\n" fname)); + let cil = Stats.time "conv" Cabs2cil.convFile cabs in + if !doPrintProtos then (printPrototypes cabs); + cil + + + + + + + + diff --git a/cil/src/frontc/frontc.mli b/cil/src/frontc/frontc.mli new file mode 100644 index 0000000..50ad799 --- /dev/null +++ b/cil/src/frontc/frontc.mli @@ -0,0 +1,55 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + + (* Signal that we are in MS VC mode *) +val setMSVCMode: unit -> unit + + + (* Parse a file in *) +exception ParseError of string + + (* Raised when the front-end is requested to print the CABS and return *) +exception CabsOnly + + (* additional command line arguments *) +val args: (string * Arg.spec * string) list + + (* the main command to parse a file. Return a thunk that can be used to + * convert the AST to CIL. *) +val parse: string -> (unit -> Cil.file) + diff --git a/cil/src/frontc/lexerhack.ml b/cil/src/frontc/lexerhack.ml new file mode 100755 index 0000000..ecae28e --- /dev/null +++ b/cil/src/frontc/lexerhack.ml @@ -0,0 +1,22 @@ + +module E = Errormsg + +(* We provide here a pointer to a function. It will be set by the lexer and + * used by the parser. In Ocaml lexers depend on parsers, so we we have put + * such functions in a separate module. *) +let add_identifier: (string -> unit) ref = + ref (fun _ -> E.s (E.bug "You called an uninitialized add_identifier")) + +let add_type: (string -> unit) ref = + ref (fun _ -> E.s (E.bug "You called an uninitialized add_type")) + +let push_context: (unit -> unit) ref = + ref (fun _ -> E.s (E.bug "You called an uninitialized push_context")) + +let pop_context: (unit -> unit) ref = + ref (fun _ -> E.s (E.bug "You called an uninitialized pop_context")) + + +(* Keep here the current pattern for formatparse *) +let currentPattern = ref "" + diff --git a/cil/src/frontc/patch.ml b/cil/src/frontc/patch.ml new file mode 100644 index 0000000..fcb4ba6 --- /dev/null +++ b/cil/src/frontc/patch.ml @@ -0,0 +1,837 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + +(* patch.ml *) +(* CABS file patching *) + +open Cabs +open Trace +open Pretty +open Cabsvisit + +(* binding of a unification variable to a syntactic construct *) +type binding = + | BSpecifier of string * spec_elem list + | BName of string * string + | BExpr of string * expression + +(* thrown when unification fails *) +exception NoMatch + +(* thrown when an attempt to find the associated binding fails *) +exception BadBind of string + +(* trying to isolate performance problems; will hide all the *) +(* potentially expensive debugging output behind "if verbose .." *) +let verbose : bool = true + + +(* raise NoMatch if x and y are not equal *) +let mustEq (x : 'a) (y : 'a) : unit = +begin + if (x <> y) then ( + if verbose then + (trace "patchDebug" (dprintf "mismatch by structural disequality\n")); + raise NoMatch + ) +end + +(* why isn't this in the core Ocaml library? *) +let identity x = x + + +let isPatternVar (s : string) : bool = +begin + ((String.length s) >= 1) && ((String.get s 0) = '@') +end + +(* 's' is actually "@name(blah)"; extract the 'blah' *) +let extractPatternVar (s : string) : string = + (*(trace "patch" (dprintf "extractPatternVar %s\n" s));*) + (String.sub s 6 ((String.length s) - 7)) + + +(* a few debugging printers.. *) +let printExpr (e : expression) = +begin + if (verbose && traceActive "patchDebug") then ( + Cprint.print_expression e; Cprint.force_new_line (); + Cprint.flush () + ) +end + +let printSpec (spec: spec_elem list) = +begin + if (verbose && traceActive "patchDebug") then ( + Cprint.print_specifiers spec; Cprint.force_new_line (); + Cprint.flush () + ) +end + +let printSpecs (pat : spec_elem list) (tgt : spec_elem list) = +begin + (printSpec pat); + (printSpec tgt) +end + +let printDecl (pat : name) (tgt : name) = +begin + if (verbose && traceActive "patchDebug") then ( + Cprint.print_name pat; Cprint.force_new_line (); + Cprint.print_name tgt; Cprint.force_new_line (); + Cprint.flush () + ) +end + +let printDeclType (pat : decl_type) (tgt : decl_type) = +begin + if (verbose && traceActive "patchDebug") then ( + Cprint.print_decl "__missing_field_name" pat; Cprint.force_new_line (); + Cprint.print_decl "__missing_field_name" tgt; Cprint.force_new_line (); + Cprint.flush () + ) +end + +let printDefn (d : definition) = +begin + if (verbose && traceActive "patchDebug") then ( + Cprint.print_def d; + Cprint.flush () + ) +end + + +(* class to describe how to modify the tree for subtitution *) +class substitutor (bindings : binding list) = object(self) + inherit nopCabsVisitor as super + + (* look in the binding list for a given name *) + method findBinding (name : string) : binding = + begin + try + (List.find + (fun b -> + match b with + | BSpecifier(n, _) -> n=name + | BName(n, _) -> n=name + | BExpr(n, _) -> n=name) + bindings) + with + Not_found -> raise (BadBind ("name not found: " ^ name)) + end + + method vexpr (e:expression) : expression visitAction = + begin + match e with + | EXPR_PATTERN(name) -> ( + match (self#findBinding name) with + | BExpr(_, expr) -> ChangeTo(expr) (* substitute bound expression *) + | _ -> raise (BadBind ("wrong type: " ^ name)) + ) + | _ -> DoChildren + end + + (* use of a name *) + method vvar (s:string) : string = + begin + if (isPatternVar s) then ( + let nameString = (extractPatternVar s) in + match (self#findBinding nameString) with + | BName(_, str) -> str (* substitute *) + | _ -> raise (BadBind ("wrong type: " ^ nameString)) + ) + else + s + end + + (* binding introduction of a name *) + method vname (k: nameKind) (spec: specifier) (n: name) : name visitAction = + begin + match n with (s (*variable name*), dtype, attrs, loc) -> ( + let replacement = (self#vvar s) in (* use replacer from above *) + if (s <> replacement) then + ChangeTo(replacement, dtype, attrs, loc) + else + DoChildren (* no replacement *) + ) + end + + method vspec (specList: specifier) : specifier visitAction = + begin + if verbose then (trace "patchDebug" (dprintf "substitutor: vspec\n")); + (printSpec specList); + + (* are any of the specifiers SpecPatterns? we have to check the entire *) + (* list, not just the head, because e.g. "typedef @specifier(foo)" has *) + (* "typedef" as the head of the specifier list *) + if (List.exists (fun elt -> match elt with + | SpecPattern(_) -> true + | _ -> false) + specList) then begin + (* yes, replace the existing list with one got by *) + (* replacing all occurrences of SpecPatterns *) + (trace "patchDebug" (dprintf "at least one spec pattern\n")); + ChangeTo + (List.flatten + (List.map + (* for each specifier element, yield the specifier list *) + (* to which it maps; then we'll flatten the final result *) + (fun elt -> + match elt with + | SpecPattern(name) -> ( + match (self#findBinding name) with + | BSpecifier(_, replacement) -> ( + (trace "patchDebug" (dprintf "replacing pattern %s\n" name)); + replacement + ) + | _ -> raise (BadBind ("wrong type: " ^ name)) + ) + | _ -> [elt] (* leave this one alone *) + ) + specList + ) + ) + end + else + (* none of the specifiers in specList are patterns *) + DoChildren + end + + method vtypespec (tspec: typeSpecifier) : typeSpecifier visitAction = + begin + match tspec with + | Tnamed(str) when (isPatternVar str) -> + ChangeTo(Tnamed(self#vvar str)) + | Tstruct(str, fields, extraAttrs) when (isPatternVar str) -> ( + (trace "patchDebug" (dprintf "substituting %s\n" str)); + ChangeDoChildrenPost(Tstruct((self#vvar str), fields, extraAttrs), identity) + ) + | Tunion(str, fields, extraAttrs) when (isPatternVar str) -> + (trace "patchDebug" (dprintf "substituting %s\n" str)); + ChangeDoChildrenPost(Tunion((self#vvar str), fields, extraAttrs), identity) + | _ -> DoChildren + end + +end + + +(* why can't I have forward declarations in the language?!! *) +let unifyExprFwd : (expression -> expression -> binding list) ref + = ref (fun e e -> []) + + +(* substitution for expressions *) +let substExpr (bindings : binding list) (expr : expression) : expression = +begin + if verbose then + (trace "patchDebug" (dprintf "substExpr with %d bindings\n" (List.length bindings))); + (printExpr expr); + + (* apply the transformation *) + let result = (visitCabsExpression (new substitutor bindings :> cabsVisitor) expr) in + (printExpr result); + + result +end + +let d_loc (_:unit) (loc: cabsloc) : doc = + text loc.filename ++ chr ':' ++ num loc.lineno + + +(* class to describe how to modify the tree when looking for places *) +(* to apply expression transformers *) +class exprTransformer (srcpattern : expression) (destpattern : expression) + (patchline : int) (srcloc : cabsloc) = object(self) + inherit nopCabsVisitor as super + + method vexpr (e:expression) : expression visitAction = + begin + (* see if the source pattern matches this subexpression *) + try ( + let bindings = (!unifyExprFwd srcpattern e) in + + (* match! *) + (trace "patch" (dprintf "expr match: patch line %d, src %a\n" + patchline d_loc srcloc)); + ChangeTo(substExpr bindings destpattern) + ) + + with NoMatch -> ( + (* doesn't apply *) + DoChildren + ) + end + + (* other constructs left unchanged *) +end + + +let unifyList (pat : 'a list) (tgt : 'a list) + (unifyElement : 'a -> 'a -> binding list) : binding list = +begin + if verbose then + (trace "patchDebug" (dprintf "unifyList (pat len %d, tgt len %d)\n" + (List.length pat) (List.length tgt))); + + (* walk down the lists *) + let rec loop pat tgt : binding list = + match pat, tgt with + | [], [] -> [] + | (pelt :: prest), (telt :: trest) -> + (unifyElement pelt telt) @ + (loop prest trest) + | _,_ -> ( + (* no match *) + if verbose then ( + (trace "patchDebug" (dprintf "mismatching list length\n")); + ); + raise NoMatch + ) + in + (loop pat tgt) +end + + +let gettime () : float = + (Unix.times ()).Unix.tms_utime + +let rec applyPatch (patchFile : file) (srcFile : file) : file = +begin + let patch : definition list = (snd patchFile) in + let srcFname : string = (fst srcFile) in + let src : definition list = (snd srcFile) in + + (trace "patchTime" (dprintf "applyPatch start: %f\n" (gettime ()))); + if (traceActive "patchDebug") then + Cprint.out := stdout (* hack *) + else (); + + (* more hackery *) + unifyExprFwd := unifyExpr; + + (* patch a single source definition, yield transformed *) + let rec patchDefn (patch : definition list) (d : definition) : definition list = + begin + match patch with + | TRANSFORMER(srcpattern, destpattern, loc) :: rest -> ( + if verbose then + (trace "patchDebug" + (dprintf "considering applying defn pattern at line %d to src at %a\n" + loc.lineno d_loc (get_definitionloc d))); + + (* see if the source pattern matches the definition 'd' we have *) + try ( + let bindings = (unifyDefn srcpattern d) in + + (* we have a match! apply the substitutions *) + (trace "patch" (dprintf "defn match: patch line %d, src %a\n" + loc.lineno d_loc (get_definitionloc d))); + + (List.map (fun destElt -> (substDefn bindings destElt)) destpattern) + ) + + with NoMatch -> ( + (* no match, continue down list *) + (*(trace "patch" (dprintf "no match\n"));*) + (patchDefn rest d) + ) + ) + + | EXPRTRANSFORMER(srcpattern, destpattern, loc) :: rest -> ( + if verbose then + (trace "patchDebug" + (dprintf "considering applying expr pattern at line %d to src at %a\n" + loc.lineno d_loc (get_definitionloc d))); + + (* walk around in 'd' looking for expressions to modify *) + let dList = (visitCabsDefinition + ((new exprTransformer srcpattern destpattern + loc.lineno (get_definitionloc d)) + :> cabsVisitor) + d + ) in + + (* recursively invoke myself to try additional patches *) + (* since visitCabsDefinition might return a list, I'll try my *) + (* addtional patches on every yielded definition, then collapse *) + (* all of them into a single list *) + (List.flatten (List.map (fun d -> (patchDefn rest d)) dList)) + ) + + | _ :: rest -> ( + (* not a transformer; just keep going *) + (patchDefn rest d) + ) + | [] -> ( + (* reached the end of the patch file with no match *) + [d] (* have to wrap it in a list ... *) + ) + end in + + (* transform all the definitions *) + let result : definition list = + (List.flatten (List.map (fun d -> (patchDefn patch d)) src)) in + + (*Cprint.print_defs result;*) + + if (traceActive "patchDebug") then ( + (* avoid flush bug? yes *) + Cprint.force_new_line (); + Cprint.flush () + ); + + (trace "patchTime" (dprintf "applyPatch finish: %f\n" (gettime ()))); + (srcFname, result) +end + + +(* given a definition pattern 'pat', and a target concrete defintion 'tgt', *) +(* determine if they can be unified; if so, return the list of bindings of *) +(* unification variables in pat; otherwise raise NoMatch *) +and unifyDefn (pat : definition) (tgt : definition) : binding list = +begin + match pat, tgt with + | DECDEF((pspecifiers, pdeclarators), _), + DECDEF((tspecifiers, tdeclarators), _) -> ( + if verbose then + (trace "patchDebug" (dprintf "unifyDefn of DECDEFs\n")); + (unifySpecifiers pspecifiers tspecifiers) @ + (unifyInitDeclarators pdeclarators tdeclarators) + ) + + | TYPEDEF((pspec, pdecl), _), + TYPEDEF((tspec, tdecl), _) -> ( + if verbose then + (trace "patchDebug" (dprintf "unifyDefn of TYPEDEFs\n")); + (unifySpecifiers pspec tspec) @ + (unifyDeclarators pdecl tdecl) + ) + + | ONLYTYPEDEF(pspec, _), + ONLYTYPEDEF(tspec, _) -> ( + if verbose then + (trace "patchDebug" (dprintf "unifyDefn of ONLYTYPEDEFs\n")); + (unifySpecifiers pspec tspec) + ) + + | _, _ -> ( + if verbose then + (trace "patchDebug" (dprintf "mismatching definitions\n")); + raise NoMatch + ) +end + +and unifySpecifier (pat : spec_elem) (tgt : spec_elem) : binding list = +begin + if verbose then + (trace "patchDebug" (dprintf "unifySpecifier\n")); + (printSpecs [pat] [tgt]); + + if (pat = tgt) then [] else + + match pat, tgt with + | SpecType(tspec1), SpecType(tspec2) -> + (unifyTypeSpecifier tspec1 tspec2) + | SpecPattern(name), _ -> + (* record that future occurrances of @specifier(name) will yield this specifier *) + if verbose then + (trace "patchDebug" (dprintf "found specifier match for %s\n" name)); + [BSpecifier(name, [tgt])] + | _,_ -> ( + (* no match *) + if verbose then ( + (trace "patchDebug" (dprintf "mismatching specifiers\n")); + ); + raise NoMatch + ) +end + +and unifySpecifiers (pat : spec_elem list) (tgt : spec_elem list) : binding list = +begin + if verbose then + (trace "patchDebug" (dprintf "unifySpecifiers\n")); + (printSpecs pat tgt); + + (* canonicalize the specifiers by sorting them *) + let pat' = (List.stable_sort compare pat) in + let tgt' = (List.stable_sort compare tgt) in + + (* if they are equal, they match with no further checking *) + if (pat' = tgt') then [] else + + (* walk down the lists; don't walk the sorted lists because the *) + (* pattern must always be last, if it occurs *) + let rec loop pat tgt : binding list = + match pat, tgt with + | [], [] -> [] + | [SpecPattern(name)], _ -> + (* final SpecPattern matches anything which comes after *) + (* record that future occurrences of @specifier(name) will yield this specifier *) + if verbose then + (trace "patchDebug" (dprintf "found specifier match for %s\n" name)); + [BSpecifier(name, tgt)] + | (pspec :: prest), (tspec :: trest) -> + (unifySpecifier pspec tspec) @ + (loop prest trest) + | _,_ -> ( + (* no match *) + if verbose then ( + (trace "patchDebug" (dprintf "mismatching specifier list length\n")); + ); + raise NoMatch + ) + in + (loop pat tgt) +end + +and unifyTypeSpecifier (pat: typeSpecifier) (tgt: typeSpecifier) : binding list = +begin + if verbose then + (trace "patchDebug" (dprintf "unifyTypeSpecifier\n")); + + if (pat = tgt) then [] else + + match pat, tgt with + | Tnamed(s1), Tnamed(s2) -> (unifyString s1 s2) + | Tstruct(name1, None, _), Tstruct(name2, None, _) -> + (unifyString name1 name2) + | Tstruct(name1, Some(fields1), _), Tstruct(name2, Some(fields2), _) -> + (* ignoring extraAttrs b/c we're just trying to come up with a list + * of substitutions, and there's no unify_attributes function, and + * I don't care at this time about checking that they are equal .. *) + (unifyString name1 name2) @ + (unifyList fields1 fields2 unifyField) + | Tunion(name1, None, _), Tstruct(name2, None, _) -> + (unifyString name1 name2) + | Tunion(name1, Some(fields1), _), Tunion(name2, Some(fields2), _) -> + (unifyString name1 name2) @ + (unifyList fields1 fields2 unifyField) + | Tenum(name1, None, _), Tenum(name2, None, _) -> + (unifyString name1 name2) + | Tenum(name1, Some(items1), _), Tenum(name2, Some(items2), _) -> + (mustEq items1 items2); (* enum items *) + (unifyString name1 name2) + | TtypeofE(exp1), TtypeofE(exp2) -> + (unifyExpr exp1 exp2) + | TtypeofT(spec1, dtype1), TtypeofT(spec2, dtype2) -> + (unifySpecifiers spec1 spec2) @ + (unifyDeclType dtype1 dtype2) + | _ -> ( + if verbose then (trace "patchDebug" (dprintf "mismatching typeSpecifiers\n")); + raise NoMatch + ) +end + +and unifyField (pat : field_group) (tgt : field_group) : binding list = +begin + match pat,tgt with (spec1, list1), (spec2, list2) -> ( + (unifySpecifiers spec1 spec2) @ + (unifyList list1 list2 unifyNameExprOpt) + ) +end + +and unifyNameExprOpt (pat : name * expression option) + (tgt : name * expression option) : binding list = +begin + match pat,tgt with + | (name1, None), (name2, None) -> (unifyName name1 name2) + | (name1, Some(exp1)), (name2, Some(exp2)) -> + (unifyName name1 name2) @ + (unifyExpr exp1 exp2) + | _,_ -> [] +end + +and unifyName (pat : name) (tgt : name) : binding list = +begin + match pat,tgt with (pstr, pdtype, pattrs, ploc), (tstr, tdtype, tattrs, tloc) -> + (mustEq pattrs tattrs); + (unifyString pstr tstr) @ + (unifyDeclType pdtype tdtype) +end + +and unifyInitDeclarators (pat : init_name list) (tgt : init_name list) : binding list = +begin + (* + if verbose then + (trace "patchDebug" (dprintf "unifyInitDeclarators, pat %d, tgt %d\n" + (List.length pat) (List.length tgt))); + *) + + match pat, tgt with + | ((pdecl, piexpr) :: prest), + ((tdecl, tiexpr) :: trest) -> + (unifyDeclarator pdecl tdecl) @ + (unifyInitExpr piexpr tiexpr) @ + (unifyInitDeclarators prest trest) + | [], [] -> [] + | _, _ -> ( + if verbose then + (trace "patchDebug" (dprintf "mismatching init declarators\n")); + raise NoMatch + ) +end + +and unifyDeclarators (pat : name list) (tgt : name list) : binding list = + (unifyList pat tgt unifyDeclarator) + +and unifyDeclarator (pat : name) (tgt : name) : binding list = +begin + if verbose then + (trace "patchDebug" (dprintf "unifyDeclarator\n")); + (printDecl pat tgt); + + match pat, tgt with + | (pname, pdtype, pattr, ploc), + (tname, tdtype, tattr, tloc) -> + (mustEq pattr tattr); + (unifyDeclType pdtype tdtype) @ + (unifyString pname tname) +end + +and unifyDeclType (pat : decl_type) (tgt : decl_type) : binding list = +begin + if verbose then + (trace "patchDebug" (dprintf "unifyDeclType\n")); + (printDeclType pat tgt); + + match pat, tgt with + | JUSTBASE, JUSTBASE -> [] + | PARENTYPE(pattr1, ptype, pattr2), + PARENTYPE(tattr1, ttype, tattr2) -> + (mustEq pattr1 tattr1); + (mustEq pattr2 tattr2); + (unifyDeclType ptype ttype) + | ARRAY(ptype, pattr, psz), + ARRAY(ttype, tattr, tsz) -> + (mustEq pattr tattr); + (unifyDeclType ptype ttype) @ + (unifyExpr psz tsz) + | PTR(pattr, ptype), + PTR(tattr, ttype) -> + (mustEq pattr tattr); + (unifyDeclType ptype ttype) + | PROTO(ptype, pformals, pva), + PROTO(ttype, tformals, tva) -> + (mustEq pva tva); + (unifyDeclType ptype ttype) @ + (unifySingleNames pformals tformals) + | _ -> ( + if verbose then + (trace "patchDebug" (dprintf "mismatching decl_types\n")); + raise NoMatch + ) +end + +and unifySingleNames (pat : single_name list) (tgt : single_name list) : binding list = +begin + if verbose then + (trace "patchDebug" (dprintf "unifySingleNames, pat %d, tgt %d\n" + (List.length pat) (List.length tgt))); + + match pat, tgt with + | [], [] -> [] + | (pspec, pdecl) :: prest, + (tspec, tdecl) :: trest -> + (unifySpecifiers pspec tspec) @ + (unifyDeclarator pdecl tdecl) @ + (unifySingleNames prest trest) + | _, _ -> ( + if verbose then + (trace "patchDebug" (dprintf "mismatching single_name lists\n")); + raise NoMatch + ) +end + +and unifyString (pat : string) (tgt : string) : binding list = +begin + (* equal? match with no further ado *) + if (pat = tgt) then [] else + + (* is the pattern a variable? *) + if (isPatternVar pat) then + (* pat is actually "@name(blah)"; extract the 'blah' *) + let varname = (extractPatternVar pat) in + + (* when substituted, this name becomes 'tgt' *) + if verbose then + (trace "patchDebug" (dprintf "found name match for %s\n" varname)); + [BName(varname, tgt)] + + else ( + if verbose then + (trace "patchDebug" (dprintf "mismatching names: %s and %s\n" pat tgt)); + raise NoMatch + ) +end + +and unifyExpr (pat : expression) (tgt : expression) : binding list = +begin + (* if they're equal, that's good enough *) + if (pat = tgt) then [] else + + (* shorter name *) + let ue = unifyExpr in + + (* because of the equality check above, I can omit some cases *) + match pat, tgt with + | UNARY(pop, pexpr), + UNARY(top, texpr) -> + (mustEq pop top); + (ue pexpr texpr) + | BINARY(pop, pexp1, pexp2), + BINARY(top, texp1, texp2) -> + (mustEq pop top); + (ue pexp1 texp1) @ + (ue pexp2 texp2) + | QUESTION(p1, p2, p3), + QUESTION(t1, t2, t3) -> + (ue p1 t1) @ + (ue p2 t2) @ + (ue p3 t3) + | CAST((pspec, ptype), piexpr), + CAST((tspec, ttype), tiexpr) -> + (mustEq ptype ttype); + (unifySpecifiers pspec tspec) @ + (unifyInitExpr piexpr tiexpr) + | CALL(pfunc, pargs), + CALL(tfunc, targs) -> + (ue pfunc tfunc) @ + (unifyExprs pargs targs) + | COMMA(pexprs), + COMMA(texprs) -> + (unifyExprs pexprs texprs) + | EXPR_SIZEOF(pexpr), + EXPR_SIZEOF(texpr) -> + (ue pexpr texpr) + | TYPE_SIZEOF(pspec, ptype), + TYPE_SIZEOF(tspec, ttype) -> + (mustEq ptype ttype); + (unifySpecifiers pspec tspec) + | EXPR_ALIGNOF(pexpr), + EXPR_ALIGNOF(texpr) -> + (ue pexpr texpr) + | TYPE_ALIGNOF(pspec, ptype), + TYPE_ALIGNOF(tspec, ttype) -> + (mustEq ptype ttype); + (unifySpecifiers pspec tspec) + | INDEX(parr, pindex), + INDEX(tarr, tindex) -> + (ue parr tarr) @ + (ue pindex tindex) + | MEMBEROF(pexpr, pfield), + MEMBEROF(texpr, tfield) -> + (mustEq pfield tfield); + (ue pexpr texpr) + | MEMBEROFPTR(pexpr, pfield), + MEMBEROFPTR(texpr, tfield) -> + (mustEq pfield tfield); + (ue pexpr texpr) + | GNU_BODY(pblock), + GNU_BODY(tblock) -> + (mustEq pblock tblock); + [] + | EXPR_PATTERN(name), _ -> + (* match, and contribute binding *) + if verbose then + (trace "patchDebug" (dprintf "found expr match for %s\n" name)); + [BExpr(name, tgt)] + | a, b -> + if (verbose && traceActive "patchDebug") then ( + (trace "patchDebug" (dprintf "mismatching expression\n")); + (printExpr a); + (printExpr b) + ); + raise NoMatch +end + +and unifyInitExpr (pat : init_expression) (tgt : init_expression) : binding list = +begin + (* + Cprint.print_init_expression pat; Cprint.force_new_line (); + Cprint.print_init_expression tgt; Cprint.force_new_line (); + Cprint.flush (); + *) + + match pat, tgt with + | NO_INIT, NO_INIT -> [] + | SINGLE_INIT(pe), SINGLE_INIT(te) -> + (unifyExpr pe te) + | COMPOUND_INIT(plist), + COMPOUND_INIT(tlist) -> ( + let rec loop plist tlist = + match plist, tlist with + | ((pwhat, piexpr) :: prest), + ((twhat, tiexpr) :: trest) -> + (mustEq pwhat twhat); + (unifyInitExpr piexpr tiexpr) @ + (loop prest trest) + | [], [] -> [] + | _, _ -> ( + if verbose then + (trace "patchDebug" (dprintf "mismatching compound init exprs\n")); + raise NoMatch + ) + in + (loop plist tlist) + ) + | _,_ -> ( + if verbose then + (trace "patchDebug" (dprintf "mismatching init exprs\n")); + raise NoMatch + ) +end + +and unifyExprs (pat : expression list) (tgt : expression list) : binding list = + (unifyList pat tgt unifyExpr) + + +(* given the list of bindings 'b', substitute them into 'd' to yield a new definition *) +and substDefn (bindings : binding list) (defn : definition) : definition = +begin + if verbose then + (trace "patchDebug" (dprintf "substDefn with %d bindings\n" (List.length bindings))); + (printDefn defn); + + (* apply the transformation *) + match (visitCabsDefinition (new substitutor bindings :> cabsVisitor) defn) with + | [d] -> d (* expect a singleton list *) + | _ -> (failwith "didn't get a singleton list where I expected one") +end + + +(* end of file *) diff --git a/cil/src/frontc/patch.mli b/cil/src/frontc/patch.mli new file mode 100644 index 0000000..4f32870 --- /dev/null +++ b/cil/src/frontc/patch.mli @@ -0,0 +1,42 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + + +(* patch.mli *) +(* interface for patch.ml *) + +val applyPatch : Cabs.file -> Cabs.file -> Cabs.file diff --git a/cil/src/libmaincil.ml b/cil/src/libmaincil.ml new file mode 100644 index 0000000..952c013 --- /dev/null +++ b/cil/src/libmaincil.ml @@ -0,0 +1,108 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* libmaincil *) +(* this is a replacement for maincil.ml, for the case when we're + * creating a C-callable library (libcil.a); all it does is register + * a couple of functions and initialize CIL *) + + +module E = Errormsg + +open Cil + + +(* print a Cil 'file' to stdout *) +let unparseToStdout (cil : file) : unit = +begin + dumpFile defaultCilPrinter stdout cil +end;; + +(* a visitor to unroll all types - may need to do some magic to keep attributes *) +class unrollVisitorClass = object (self) + inherit nopCilVisitor + + (* variable declaration *) + method vvdec (vi : varinfo) : varinfo visitAction = + begin + vi.vtype <- unrollTypeDeep vi.vtype; + (*ignore (E.log "varinfo for %s in file '%s' line %d byte %d\n" vi.vname vi.vdecl.file vi.vdecl.line vi.vdecl.byte);*) + SkipChildren + end + + (* global: need to unroll fields of compinfo *) + method vglob (g : global) : global list visitAction = + begin + match g with + GCompTag(ci, loc) as g -> + let doFieldinfo (fi : fieldinfo) : unit = + fi.ftype <- unrollTypeDeep fi.ftype + in begin + ignore(List.map doFieldinfo ci.cfields); + (*ChangeTo [g]*) + SkipChildren + end + | _ -> DoChildren + end +end;; + + +let unrollVisitor = new unrollVisitorClass;; + +(* open and parse a C file into a Cil 'file', unroll all typedefs *) +let parseOneFile (fname: string) : file = + let ast : file = Frontc.parse fname () in + begin + visitCilFile unrollVisitor ast; + ast + end +;; + +let getDummyTypes () : typ * typ = + ( TPtr(TVoid [], []), TInt(IInt, []) ) +;; + +(* register some functions - these may be called from C code *) +Callback.register "cil_parse" parseOneFile; +Callback.register "cil_unparse" unparseToStdout; +(* Callback.register "unroll_type_deep" unrollTypeDeep; *) +Callback.register "get_dummy_types" getDummyTypes; + +(* initalize CIL *) +initCIL (); + + diff --git a/cil/src/machdep.c b/cil/src/machdep.c new file mode 100644 index 0000000..1134865 --- /dev/null +++ b/cil/src/machdep.c @@ -0,0 +1,220 @@ +/* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + */ + +#include "../config.h" + +#include + +#ifdef HAVE_STDLIB_H +#include +#endif + +#ifdef HAVE_WCHAR_H +#include +#endif + +#ifdef _GNUCC +#define LONGLONG long long +#define CONST_STRING_LITERALS "true" +#define VERSION __VERSION__ +#define VERSION_MAJOR __GNUC__ +#define VERSION_MINOR __GNUC_MINOR__ +#endif + +#ifdef _MSVC +#define LONGLONG __int64 +#define CONST_STRING_LITERALS "false" +#define VERSION "0" +#define VERSION_MAJOR 0 +#define VERSION_MINOR 0 +#endif + +/* The type for the machine dependency structure is generated from the + Makefile */ +int main() { + fprintf(stderr, "Generating machine dependency information for CIL\n"); + + printf("(* Generated by code in %s *)\n", __FILE__); + printf("\t version_major = %d;\n", VERSION_MAJOR); + printf("\t version_minor = %d;\n", VERSION_MINOR); + printf("\t version = \"%s\";\n", VERSION); + // Size of certain types + printf("\t sizeof_short = %d;\n", sizeof(short)); + printf("\t sizeof_int = %d;\n", sizeof(int)); + printf("\t sizeof_long = %d;\n", sizeof(long)); + printf("\t sizeof_longlong = %d;\n", sizeof(LONGLONG)); + printf("\t sizeof_ptr = %d;\n", sizeof(int *)); + printf("\t sizeof_enum = %d;\n", sizeof(enum e { ONE, TWO })); + printf("\t sizeof_float = %d;\n", sizeof(float)); + printf("\t sizeof_double = %d;\n", sizeof(double)); + printf("\t sizeof_longdouble = %d;\n", sizeof(long double)); + printf("\t sizeof_sizeof = %d;\n", sizeof(sizeof(int))); + printf("\t sizeof_wchar = %d;\n", sizeof(wchar_t)); + printf("\t sizeof_void = %d;\n", sizeof(void)); + printf("\t sizeof_fun = %d;\n", +#ifdef __GNUC__ + sizeof(main) +#else + 0 +#endif + ); + + // The alignment of a short + { + struct shortstruct { + char c; + short s; + }; + printf("\t alignof_short = %d;\n", + (int)(&((struct shortstruct*)0)->s)); + } + + // The alignment of an int + { + struct intstruct { + char c; + int i; + }; + printf("\t alignof_int = %d;\n", + (int)(&((struct intstruct*)0)->i)); + } + + // The alignment of a long + { + struct longstruct { + char c; + long l; + }; + printf("\t alignof_long = %d;\n", + (int)(&((struct longstruct*)0)->l)); + } + + // The alignment of long long + { + struct longlong { + char c; + LONGLONG ll; + }; + printf("\t alignof_longlong = %d;\n", + (int)(&((struct longlong*)0)->ll)); + } + + // The alignment of a ptr + { + struct ptrstruct { + char c; + int * p; + }; + printf("\t alignof_ptr = %d;\n", + (int)(&((struct ptrstruct*)0)->p)); + } + + // The alignment of an enum + { + struct enumstruct { + char c; + enum e2 { THREE, FOUR, FIVE } e; + }; + printf("\t alignof_enum = %d;\n", + (int)(&((struct enumstruct*)0)->e)); + } + + // The alignment of a float + { + struct floatstruct { + char c; + float f; + }; + printf("\t alignof_float = %d;\n", + (int)(&((struct floatstruct*)0)->f)); + } + + // The alignment of double + { + struct s1 { + char c; + double d; + }; + printf("\t alignof_double = %d;\n", + (int)(&((struct s1*)0)->d)); + } + + // The alignment of long double + { + struct s1 { + char c; + long double ld; + }; + printf("\t alignof_longdouble = %d;\n", + (int)(&((struct s1*)0)->ld)); + } + + printf("\t alignof_str = %d;\n", +#ifdef __GNUC__ + __alignof("a string") +#else + 0 +#endif + ); + + printf("\t alignof_fun = %d;\n", +#ifdef __GNUC__ + __alignof(main) +#else + 0 +#endif + ); + + // Whether char is unsigned + printf("\t char_is_unsigned = %s;\n", + ((char)0xff) > 0 ? "true" : "false"); + + + // Whether string literals contain constant characters + puts("\t const_string_literals = " CONST_STRING_LITERALS ";"); + + + // endianity + { + int e = 0x11223344; + printf("\t little_endian = %s;\n", + (0x44 == *(char*)&e) ? "true" : + ((0x11 == *(char*)&e) ? "false" : (exit(1), "false"))); + } + + exit(0); +} diff --git a/cil/src/main.ml b/cil/src/main.ml new file mode 100644 index 0000000..bbdb730 --- /dev/null +++ b/cil/src/main.ml @@ -0,0 +1,288 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* maincil *) +(* this module is the program entry point for the 'cilly' program, *) +(* which reads a C program file, parses it, translates it to the CIL *) +(* intermediate language, and then renders that back into C *) + + +module F = Frontc +module C = Cil +module CK = Check +module E = Errormsg +open Pretty +open Trace + +type outfile = + { fname: string; + fchan: out_channel } +let outChannel : outfile option ref = ref None +let mergedChannel : outfile option ref = ref None + + +let parseOneFile (fname: string) : C.file = + (* PARSE and convert to CIL *) + if !Cilutil.printStages then ignore (E.log "Parsing %s\n" fname); + let cil = F.parse fname () in + + if (not !Epicenter.doEpicenter) then ( + (* sm: remove unused temps to cut down on gcc warnings *) + (* (Stats.time "usedVar" Rmtmps.removeUnusedTemps cil); *) + (trace "sm" (dprintf "removing unused temporaries\n")); + (Rmtmps.removeUnusedTemps cil) + ); + cil + +(** These are the statically-configured features. To these we append the + * features defined in Feature_config.ml (from Makefile) *) + +let makeCFGFeature : C.featureDescr = + { C.fd_name = "makeCFG"; + C.fd_enabled = Cilutil.makeCFG; + C.fd_description = "make the program look more like a CFG" ; + C.fd_extraopt = []; + C.fd_doit = (fun f -> + ignore (Partial.calls_end_basic_blocks f) ; + ignore (Partial.globally_unique_vids f) ; + Cil.iterGlobals f (fun glob -> match glob with + Cil.GFun(fd,_) -> Cil.prepareCFG fd ; + (* jc: blockinggraph depends on this "true" arg *) + ignore (Cil.computeCFGInfo fd true) + | _ -> ()) + ); + C.fd_post_check = true; + } + +let features : C.featureDescr list = + [ Epicenter.feature; + Simplify.feature; + Canonicalize.feature; + Callgraph.feature; + Logwrites.feature; + Heapify.feature1; + Heapify.feature2; + Oneret.feature; + makeCFGFeature; (* ww: make CFG *must* come before Partial *) + Partial.feature; + Simplemem.feature; + Sfi.feature; + Dataslicing.feature; + Logcalls.feature; + Ptranal.feature; + Liveness.feature; + ] + @ Feature_config.features + +let rec processOneFile (cil: C.file) = + begin + + if !Cilutil.doCheck then begin + ignore (E.log "First CIL check\n"); + ignore (CK.checkFile [] cil); + end; + + (* Scan all the features configured from the Makefile and, if they are + * enabled then run them on the current file *) + List.iter + (fun fdesc -> + if ! (fdesc.C.fd_enabled) then begin + if !E.verboseFlag then + ignore (E.log "Running CIL feature %s (%s)\n" + fdesc.C.fd_name fdesc.C.fd_description); + (* Run the feature, and see how long it takes. *) + Stats.time fdesc.C.fd_name + fdesc.C.fd_doit cil; + (* See if we need to do some checking *) + if !Cilutil.doCheck && fdesc.C.fd_post_check then begin + ignore (E.log "CIL check after %s\n" fdesc.C.fd_name); + ignore (CK.checkFile [] cil); + end + end) + features; + + + (match !outChannel with + None -> () + | Some c -> Stats.time "printCIL" + (C.dumpFile (!C.printerForMaincil) c.fchan c.fname) cil); + + if !E.hadErrors then + E.s (E.error "Error while processing file; see above for details."); + + end + +(***** MAIN *****) +let rec theMain () = + let usageMsg = "Usage: cilly [options] source-files" in + (* Processign of output file arguments *) + let openFile (what: string) (takeit: outfile -> unit) (fl: string) = + if !E.verboseFlag then + ignore (Printf.printf "Setting %s to %s\n" what fl); + (try takeit { fname = fl; + fchan = open_out fl } + with _ -> + raise (Arg.Bad ("Cannot open " ^ what ^ " file " ^ fl))) + in + let outName = ref "" in + (* sm: enabling this by default, since I think usually we + * want 'cilly' transformations to preserve annotations; I + * can easily add a command-line flag if someone sometimes + * wants these suppressed *) + C.print_CIL_Input := true; + + (*********** COMMAND LINE ARGUMENTS *****************) + (* Construct the arguments for the features configured from the Makefile *) + let blankLine = ("", Arg.Unit (fun _ -> ()), "") in + let featureArgs = + List.fold_right + (fun fdesc acc -> + if !(fdesc.C.fd_enabled) then + (* The feature is enabled by default *) + blankLine :: + ("--dont" ^ fdesc.C.fd_name, Arg.Clear(fdesc.C.fd_enabled), + " Disable " ^ fdesc.C.fd_description) :: + fdesc.C.fd_extraopt @ acc + else + (* Disabled by default *) + blankLine :: + ("--do" ^ fdesc.C.fd_name, Arg.Set(fdesc.C.fd_enabled), + " Enable " ^ fdesc.C.fd_description) :: + fdesc.C.fd_extraopt @ acc + ) + features + [blankLine] + in + let featureArgs = + ("", Arg.Unit (fun () -> ()), "\n\t\tCIL Features") :: featureArgs + in + + let argDescr = Ciloptions.options @ + [ + "--out", Arg.String (openFile "output" + (fun oc -> outChannel := Some oc)), + "the name of the output CIL file. The cilly script sets this for you."; + "--mergedout", Arg.String (openFile "merged output" + (fun oc -> mergedChannel := Some oc)), + "specify the name of the merged file"; + ] + @ F.args @ featureArgs in + begin + (* this point in the code is the program entry point *) + + Stats.reset (Stats.has_performance_counters ()); + + (* parse the command-line arguments *) + Arg.parse argDescr Ciloptions.recordFile usageMsg; + Cil.initCIL (); + + Ciloptions.fileNames := List.rev !Ciloptions.fileNames; + + if !Cilutil.testcil <> "" then begin + Testcil.doit !Cilutil.testcil + end else + (* parse each of the files named on the command line, to CIL *) + let files = List.map parseOneFile !Ciloptions.fileNames in + + (* if there's more than one source file, merge them together; *) + (* now we have just one CIL "file" to deal with *) + let one = + match files with + [one] -> one + | [] -> E.s (E.error "No arguments for CIL\n") + | _ -> + let merged = + Stats.time "merge" (Mergecil.merge files) + (if !outName = "" then "stdout" else !outName) in + if !E.hadErrors then + E.s (E.error "There were errors during merging\n"); + (* See if we must save the merged file *) + (match !mergedChannel with + None -> () + | Some mc -> begin + let oldpci = !C.print_CIL_Input in + C.print_CIL_Input := true; + Stats.time "printMerged" + (C.dumpFile !C.printerForMaincil mc.fchan mc.fname) merged; + C.print_CIL_Input := oldpci + end); + merged + in + + if !E.hadErrors then + E.s (E.error "Cabs2cil had some errors"); + + (* process the CIL file (merged if necessary) *) + processOneFile one + end +;; + (* Define a wrapper for main to + * intercept the exit *) +let failed = ref false + +let cleanup () = + if !E.verboseFlag || !Cilutil.printStats then + Stats.print stderr "Timings:\n"; + if !E.logChannel != stderr then + close_out (! E.logChannel); + (match ! outChannel with Some c -> close_out c.fchan | _ -> ()) + + +(* Without this handler, cilly.asm.exe will quit silently with return code 0 + when a segfault happens. *) +let handleSEGV code = + if !Cil.currentLoc == Cil.locUnknown then + E.log "**** Segmentation fault (possibly a stack overflow)\n" + else begin + E.log ("**** Segmentation fault (possibly a stack overflow) "^^ + "while processing %a\n") + Cil.d_loc !Cil.currentLoc + end; + exit code + +let _ = Sys.set_signal Sys.sigsegv (Sys.Signal_handle handleSEGV); + +;; + +begin + try + theMain (); + with F.CabsOnly -> (* this is OK *) () +end; +cleanup (); +exit (if !failed then 1 else 0) + diff --git a/cil/src/mergecil.ml b/cil/src/mergecil.ml new file mode 100644 index 0000000..dee519e --- /dev/null +++ b/cil/src/mergecil.ml @@ -0,0 +1,1770 @@ +(* MODIF: Loop constructor replaced by 3 constructors: While, DoWhile, For. *) + +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* mergecil.ml *) +(* This module is responsible for merging multiple CIL source trees into + * a single, coherent CIL tree which contains the union of all the + * definitions in the source files. It effectively acts like a linker, + * but at the source code level instead of the object code level. *) + + +module P = Pretty +open Cil +module E = Errormsg +module H = Hashtbl +module A = Alpha +open Trace + +let debugMerge = false +let debugInlines = false + +let ignore_merge_conflicts = ref false + +(* Try to merge structure with the same name. However, do not complain if + * they are not the same *) +let mergeSynonyms = true + + +(** Whether to use path compression *) +let usePathCompression = false + +(* Try to merge definitions of inline functions. They can appear in multiple + * files and we would like them all to be the same. This can slow down the + * merger an order of magnitude !!! *) +let mergeInlines = true + +let mergeInlinesRepeat = mergeInlines && true + +let mergeInlinesWithAlphaConvert = mergeInlines && true + +(* when true, merge duplicate definitions of externally-visible functions; + * this uses a mechanism which is faster than the one for inline functions, + * but only probabilistically accurate *) +let mergeGlobals = true + + +(* Return true if 's' starts with the prefix 'p' *) +let prefix p s = + let lp = String.length p in + let ls = String.length s in + lp <= ls && String.sub s 0 lp = p + + + +(* A name is identified by the index of the file in which it occurs (starting + * at 0 with the first file) and by the actual name. We'll keep name spaces + * separate *) + +(* We define a data structure for the equivalence classes *) +type 'a node = + { nname: string; (* The actual name *) + nfidx: int; (* The file index *) + ndata: 'a; (* Data associated with the node *) + mutable nloc: (location * int) option; + (* location where defined and index within the file of the definition. + * If None then it means that this node actually DOES NOT appear in the + * given file. In rare occasions we need to talk in a given file about + * types that are not defined in that file. This happens with undefined + * structures but also due to cross-contamination of types in a few of + * the cases of combineType (see the definition of combineTypes). We + * try never to choose as representatives nodes without a definition. + * We also choose as representative the one that appears earliest *) + mutable nrep: 'a node; (* A pointer to another node in its class (one + * closer to the representative). The nrep node + * is always in an earlier file, except for the + * case where a name is undefined in one file + * and defined in a later file. If this pointer + * points to the node itself then this is the + * representative. *) + mutable nmergedSyns: bool (* Whether we have merged the synonyms for + * the node of this name *) + } + +let d_nloc () (lo: (location * int) option) : P.doc = + match lo with + None -> P.text "None" + | Some (l, idx) -> P.dprintf "Some(%d at %a)" idx d_loc l + +(* Make a node with a self loop. This is quite tricky. *) +let mkSelfNode (eq: (int * string, 'a node) H.t) (* The equivalence table *) + (syn: (string, 'a node) H.t) (* The synonyms table *) + (fidx: int) (name: string) (data: 'a) + (l: (location * int) option) = + let res = { nname = name; nfidx = fidx; ndata = data; nloc = l; + nrep = Obj.magic 1; nmergedSyns = false; } in + res.nrep <- res; (* Make the self cycle *) + H.add eq (fidx, name) res; (* Add it to the proper table *) + if mergeSynonyms && not (prefix "__anon" name) then + H.add syn name res; + res + +let debugFind = false + +(* Find the representative with or without path compression *) +let rec find (pathcomp: bool) (nd: 'a node) = + if debugFind then + ignore (E.log " find %s(%d)\n" nd.nname nd.nfidx); + if nd.nrep == nd then begin + if debugFind then + ignore (E.log " = %s(%d)\n" nd.nname nd.nfidx); + nd + end else begin + let res = find pathcomp nd.nrep in + if usePathCompression && pathcomp && nd.nrep != res then + nd.nrep <- res; (* Compress the paths *) + res + end + + +(* Union two nodes and return the new representative. We prefer as the + * representative a node defined earlier. We try not to use as + * representatives nodes that are not defined in their files. We return a + * function for undoing the union. Make sure that between the union and the + * undo you do not do path compression *) +let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) = + (* Move to the representatives *) + let nd1 = find true nd1 in + let nd2 = find true nd2 in + if nd1 == nd2 then begin + (* It can happen that we are trying to union two nodes that are already + * equivalent. This is because between the time we check that two nodes + * are not already equivalent and the time we invoke the union operation + * we check type isomorphism which might change the equivalence classes *) +(* + ignore (warn "unioning already equivalent nodes for %s(%d)" + nd1.nname nd1.nfidx); +*) + nd1, fun x -> x + end else begin + let rep, norep = (* Choose the representative *) + if (nd1.nloc != None) = (nd2.nloc != None) then + (* They have the same defined status. Choose the earliest *) + if nd1.nfidx < nd2.nfidx then nd1, nd2 + else if nd1.nfidx > nd2.nfidx then nd2, nd1 + else (* In the same file. Choose the one with the earliest index *) begin + match nd1.nloc, nd2.nloc with + Some (_, didx1), Some (_, didx2) -> + if didx1 < didx2 then nd1, nd2 else + if didx1 > didx2 then nd2, nd1 + else begin + ignore (warn + "Merging two elements (%s and %s) in the same file (%d) with the same idx (%d) within the file" + nd1.nname nd2.nname nd1.nfidx didx1); + nd1, nd2 + end + | _, _ -> (* both none. Does not matter which one we choose. Should + * not happen though. *) + (* sm: it does happen quite a bit when, e.g. merging STLport with + * some client source; I'm disabling the warning since it supposedly + * is harmless anyway, so is useless noise *) + (* sm: re-enabling on claim it now will probably not happen *) + ignore (warn "Merging two undefined elements in the same file: %s and %s\n" nd1.nname nd2.nname); + nd1, nd2 + end + else (* One is defined, the other is not. Choose the defined one *) + if nd1.nloc != None then nd1, nd2 else nd2, nd1 + in + let oldrep = norep.nrep in + norep.nrep <- rep; + rep, (fun () -> norep.nrep <- oldrep) + end +(* +let union (nd1: 'a node) (nd2: 'a node) : 'a node * (unit -> unit) = + if nd1 == nd2 && nd1.nname = "!!!intEnumInfo!!!" then begin + ignore (warn "unioning two identical nodes for %s(%d)" + nd1.nname nd1.nfidx); + nd1, fun x -> x + end else + union nd1 nd2 +*) +(* Find the representative for a node and compress the paths in the process *) +let findReplacement + (pathcomp: bool) + (eq: (int * string, 'a node) H.t) + (fidx: int) + (name: string) : ('a * int) option = + if debugFind then + ignore (E.log "findReplacement for %s(%d)\n" name fidx); + try + let nd = H.find eq (fidx, name) in + if nd.nrep == nd then begin + if debugFind then + ignore (E.log " is a representative\n"); + None (* No replacement if this is the representative of its class *) + end else + let rep = find pathcomp nd in + if rep != rep.nrep then + E.s (bug "find does not return the representative\n"); + if debugFind then + ignore (E.log " RES = %s(%d)\n" rep.nname rep.nfidx); + Some (rep.ndata, rep.nfidx) + with Not_found -> begin + if debugFind then + ignore (E.log " not found in the map\n"); + None + end + +(* Make a node if one does not already exist. Otherwise return the + * representative *) +let getNode (eq: (int * string, 'a node) H.t) + (syn: (string, 'a node) H.t) + (fidx: int) (name: string) (data: 'a) + (l: (location * int) option) = + let debugGetNode = false in + if debugGetNode then + ignore (E.log "getNode(%s(%d), %a)\n" + name fidx d_nloc l); + try + let res = H.find eq (fidx, name) in + + (match res.nloc, l with + (* Maybe we have a better location now *) + None, Some _ -> res.nloc <- l + | Some (old_l, old_idx), Some (l, idx) -> + if old_idx != idx then + ignore (warn "Duplicate definition of node %s(%d) at indices %d(%a) and %d(%a)" + name fidx old_idx d_loc old_l idx d_loc l) + else + () + + | _, _ -> ()); + if debugGetNode then + ignore (E.log " node already found\n"); + find false res (* No path compression *) + with Not_found -> begin + let res = mkSelfNode eq syn fidx name data l in + if debugGetNode then + ignore (E.log " made a new one\n"); + res + end + + + +(* Dump a graph *) +let dumpGraph (what: string) (eq: (int * string, 'a node) H.t) : unit = + ignore (E.log "Equivalence graph for %s is:\n" what); + H.iter (fun (fidx, name) nd -> + ignore (E.log " %s(%d) %s-> " + name fidx (if nd.nloc = None then "(undef)" else "")); + if nd.nrep == nd then + ignore (E.log "*\n") + else + ignore (E.log " %s(%d)\n" nd.nrep.nname nd.nrep.nfidx )) + eq + + + + +(* For each name space we define a set of equivalence classes *) +let vEq: (int * string, varinfo node) H.t = H.create 111 (* Vars *) +let sEq: (int * string, compinfo node) H.t = H.create 111 (* Struct + union *) +let eEq: (int * string, enuminfo node) H.t = H.create 111 (* Enums *) +let tEq: (int * string, typeinfo node) H.t = H.create 111 (* Type names*) +let iEq: (int * string, varinfo node) H.t = H.create 111 (* Inlines *) + +(* Sometimes we want to merge synonyms. We keep some tables indexed by names. + * Each name is mapped to multiple exntries *) +let vSyn: (string, varinfo node) H.t = H.create 111 (* Not actually used *) +let iSyn: (string, varinfo node) H.t = H.create 111 (* Inlines *) +let sSyn: (string, compinfo node) H.t = H.create 111 +let eSyn: (string, enuminfo node) H.t = H.create 111 +let tSyn: (string, typeinfo node) H.t = H.create 111 + +(** A global environment for variables. Put in here only the non-static + * variables, indexed by their name. *) +let vEnv : (string, varinfo node) H.t = H.create 111 + + +(* A set of inline functions indexed by their printout ! *) +let inlineBodies : (P.doc, varinfo node) H.t = H.create 111 + +(** A number of alpha conversion tables. We ought to keep one table for each + * name space. Unfortunately, because of the way the C lexer works, type + * names must be different from variable names!! We one alpha table both for + * variables and types. *) +let vtAlpha : (string, location A.alphaTableData ref) H.t + = H.create 57 (* Variables and + * types *) +let sAlpha : (string, location A.alphaTableData ref) H.t + = H.create 57 (* Structures and + * unions have + * the same name + * space *) +let eAlpha : (string, location A.alphaTableData ref) H.t + = H.create 57 (* Enumerations *) + + +(** Keep track, for all global function definitions, of the names of the formal + * arguments. They might change during merging of function types if the + * prototype occurs after the function definition and uses different names. + * We'll restore the names at the end *) +let formalNames: (int * string, string list) H.t = H.create 111 + + +(* Accumulate here the globals in the merged file *) +let theFileTypes = ref [] +let theFile = ref [] + +(* add 'g' to the merged file *) +let mergePushGlobal (g: global) : unit = + pushGlobal g ~types:theFileTypes ~variables:theFile + +let mergePushGlobals gl = List.iter mergePushGlobal gl + + +(* The index of the current file being scanned *) +let currentFidx = ref 0 + +let currentDeclIdx = ref 0 (* The index of the definition in a file. This is + * maintained both in pass 1 and in pass 2. Make + * sure you count the same things in both passes. *) +(* Keep here the file names *) +let fileNames : (int, string) H.t = H.create 113 + + + +(* Remember the composite types that we have already declared *) +let emittedCompDecls: (string, bool) H.t = H.create 113 +(* Remember the variables also *) +let emittedVarDecls: (string, bool) H.t = H.create 113 + +(* also keep track of externally-visible function definitions; + * name maps to declaration, location, and semantic checksum *) +let emittedFunDefn: (string, fundec * location * int) H.t = H.create 113 +(* and same for variable definitions; name maps to GVar fields *) +let emittedVarDefn: (string, varinfo * init option * location) H.t = H.create 113 + +(** A mapping from the new names to the original names. Used in PASS2 when we + * rename variables. *) +let originalVarNames: (string, string) H.t = H.create 113 + +(* Initialize the module *) +let init () = + H.clear sAlpha; + H.clear eAlpha; + H.clear vtAlpha; + + H.clear vEnv; + + H.clear vEq; + H.clear sEq; + H.clear eEq; + H.clear tEq; + H.clear iEq; + + H.clear vSyn; + H.clear sSyn; + H.clear eSyn; + H.clear tSyn; + H.clear iSyn; + + theFile := []; + theFileTypes := []; + + H.clear formalNames; + H.clear inlineBodies; + + currentFidx := 0; + currentDeclIdx := 0; + H.clear fileNames; + + H.clear emittedVarDecls; + H.clear emittedCompDecls; + + H.clear emittedFunDefn; + H.clear emittedVarDefn; + + H.clear originalVarNames + + +(* Some enumerations have to be turned into an integer. We implement this by + * introducing a special enumeration type which we'll recognize later to be + * an integer *) +let intEnumInfo = + { ename = "!!!intEnumInfo!!!"; (* This is otherwise invalid *) + eitems = []; + eattr = []; + ereferenced = false; + } +(* And add it to the equivalence graph *) +let intEnumInfoNode = + getNode eEq eSyn 0 intEnumInfo.ename intEnumInfo + (Some (locUnknown, 0)) + + (* Combine the types. Raises the Failure exception with an error message. + * isdef says whether the new type is for a definition *) +type combineWhat = + CombineFundef (* The new definition is for a function definition. The old + * is for a prototype *) + | CombineFunarg (* Comparing a function argument type with an old prototype + * arg *) + | CombineFunret (* Comparing the return of a function with that from an old + * prototype *) + | CombineOther + + +let rec combineTypes (what: combineWhat) + (oldfidx: int) (oldt: typ) + (fidx: int) (t: typ) : typ = + match oldt, t with + | TVoid olda, TVoid a -> TVoid (addAttributes olda a) + | TInt (oldik, olda), TInt (ik, a) -> + let combineIK oldk k = + if oldk == k then oldk else + (* GCC allows a function definition to have a more precise integer + * type than a prototype that says "int" *) + if not !msvcMode && oldk = IInt && bitsSizeOf t <= 32 + && (what = CombineFunarg || what = CombineFunret) + then + k + else ( + let msg = + P.sprint ~width:80 + (P.dprintf + "(different integer types %a and %a)" + d_type oldt d_type t) in + raise (Failure msg) + ) + in + TInt (combineIK oldik ik, addAttributes olda a) + + | TFloat (oldfk, olda), TFloat (fk, a) -> + let combineFK oldk k = + if oldk == k then oldk else + (* GCC allows a function definition to have a more precise integer + * type than a prototype that says "double" *) + if not !msvcMode && oldk = FDouble && k = FFloat + && (what = CombineFunarg || what = CombineFunret) + then + k + else + raise (Failure "(different floating point types)") + in + TFloat (combineFK oldfk fk, addAttributes olda a) + + | TEnum (oldei, olda), TEnum (ei, a) -> + (* Matching enumerations always succeeds. But sometimes it maps both + * enumerations to integers *) + matchEnumInfo oldfidx oldei fidx ei; + TEnum (oldei, addAttributes olda a) + + + (* Strange one. But seems to be handled by GCC *) + | TEnum (oldei, olda) , TInt(IInt, a) -> TEnum(oldei, + addAttributes olda a) + + (* Strange one. But seems to be handled by GCC. Warning. Here we are + * leaking types from new to old *) + | TInt(IInt, olda), TEnum (ei, a) -> TEnum(ei, addAttributes olda a) + + | TComp (oldci, olda) , TComp (ci, a) -> + matchCompInfo oldfidx oldci fidx ci; + (* If we get here we were successful *) + TComp (oldci, addAttributes olda a) + + | TArray (oldbt, oldsz, olda), TArray (bt, sz, a) -> + let combbt = combineTypes CombineOther oldfidx oldbt fidx bt in + let combinesz = + match oldsz, sz with + None, Some _ -> sz + | Some _, None -> oldsz + | None, None -> oldsz + | Some oldsz', Some sz' -> + let samesz = + match constFold true oldsz', constFold true sz' with + Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i + | _, _ -> false + in + if samesz then oldsz else + raise (Failure "(different array sizes)") + in + TArray (combbt, combinesz, addAttributes olda a) + + | TPtr (oldbt, olda), TPtr (bt, a) -> + TPtr (combineTypes CombineOther oldfidx oldbt fidx bt, + addAttributes olda a) + + (* WARNING: In this case we are leaking types from new to old !! *) + | TFun (_, _, _, [Attr("missingproto",_)]), TFun _ -> t + + + | TFun _, TFun (_, _, _, [Attr("missingproto",_)]) -> oldt + + | TFun (oldrt, oldargs, oldva, olda), TFun (rt, args, va, a) -> + let newrt = + combineTypes + (if what = CombineFundef then CombineFunret else CombineOther) + oldfidx oldrt fidx rt + in + if oldva != va then + raise (Failure "(diferent vararg specifiers)"); + (* If one does not have arguments, believe the one with the + * arguments *) + let newargs = + if oldargs = None then args else + if args = None then oldargs else + let oldargslist = argsToList oldargs in + let argslist = argsToList args in + if List.length oldargslist <> List.length argslist then + raise (Failure "(different number of arguments)") + else begin + (* Go over the arguments and update the old ones with the + * adjusted types *) + Some + (List.map2 + (fun (on, ot, oa) (an, at, aa) -> + let n = if an <> "" then an else on in + let t = + combineTypes + (if what = CombineFundef then + CombineFunarg else CombineOther) + oldfidx ot fidx at + in + let a = addAttributes oa aa in + (n, t, a)) + oldargslist argslist) + end + in + TFun (newrt, newargs, oldva, addAttributes olda a) + + | TBuiltin_va_list olda, TBuiltin_va_list a -> + TBuiltin_va_list (addAttributes olda a) + + | TNamed (oldt, olda), TNamed (t, a) -> + matchTypeInfo oldfidx oldt fidx t; + (* If we get here we were able to match *) + TNamed(oldt, addAttributes olda a) + + (* Unroll first the new type *) + | _, TNamed (t, a) -> + let res = combineTypes what oldfidx oldt fidx t.ttype in + typeAddAttributes a res + + (* And unroll the old type as well if necessary *) + | TNamed (oldt, a), _ -> + let res = combineTypes what oldfidx oldt.ttype fidx t in + typeAddAttributes a res + + | _ -> ( + (* raise (Failure "(different type constructors)") *) + let msg:string = (P.sprint 1000 (P.dprintf "(different type constructors: %a vs. %a)" + d_type oldt d_type t)) in + raise (Failure msg) + ) + + +(* Match two compinfos and throw a Failure if they do not match *) +and matchCompInfo (oldfidx: int) (oldci: compinfo) + (fidx: int) (ci: compinfo) : unit = + if oldci.cstruct <> ci.cstruct then + raise (Failure "(different struct/union types)"); + (* See if we have a mapping already *) + (* Make the nodes if not already made. Actually return the + * representatives *) + let oldcinode = getNode sEq sSyn oldfidx oldci.cname oldci None in + let cinode = getNode sEq sSyn fidx ci.cname ci None in + if oldcinode == cinode then (* We already know they are the same *) + () + else begin + (* Replace with the representative data *) + let oldci = oldcinode.ndata in + let oldfidx = oldcinode.nfidx in + let ci = cinode.ndata in + let fidx = cinode.nfidx in + + let old_len = List.length oldci.cfields in + let len = List.length ci.cfields in + (* It is easy to catch here the case when the new structure is undefined + * and the old one was defined. We just reuse the old *) + (* More complicated is the case when the old one is not defined but the + * new one is. We still reuse the old one and we'll take care of defining + * it later with the new fields. + * GN: 7/10/04, I could not find when is "later", so I added it below *) + if len <> 0 && old_len <> 0 && old_len <> len then ( + let curLoc = !currentLoc in (* d_global blows this away.. *) + (trace "merge" (P.dprintf "different # of fields\n%d: %a\n%d: %a\n" + old_len d_global (GCompTag(oldci,locUnknown)) + len d_global (GCompTag(ci,locUnknown)) + )); + currentLoc := curLoc; + let msg = Printf.sprintf + "(different number of fields in %s and %s: %d != %d.)" + oldci.cname ci.cname old_len len in + raise (Failure msg) + ); + (* We check that they are defined in the same way. While doing this there + * might be recursion and we have to watch for going into an infinite + * loop. So we add the assumption that they are equal *) + let newrep, undo = union oldcinode cinode in + (* We check the fields but watch for Failure. We only do the check when + * the lengths are the same. Due to the code above this the other + * possibility is that one of the length is 0, in which case we reuse the + * old compinfo. *) + (* But what if the old one is the empty one ? *) + if old_len = len then begin + (try + List.iter2 + (fun oldf f -> + if oldf.fbitfield <> f.fbitfield then + raise (Failure "(different bitfield info)"); + if oldf.fattr <> f.fattr then + raise (Failure "(different field attributes)"); + (* Make sure the types are compatible *) + let newtype = + combineTypes CombineOther oldfidx oldf.ftype fidx f.ftype + in + (* Change the type in the representative *) + oldf.ftype <- newtype; + ) + oldci.cfields ci.cfields + with Failure reason -> begin + (* Our assumption was wrong. Forget the isomorphism *) + undo (); + let msg = + P.sprint ~width:80 + (P.dprintf + "\n\tFailed assumption that %s and %s are isomorphic %s@!%a@!%a" + (compFullName oldci) (compFullName ci) reason + dn_global (GCompTag(oldci,locUnknown)) + dn_global (GCompTag(ci,locUnknown))) + in + raise (Failure msg) + end) + end else begin + (* We will reuse the old one. One of them is empty. If the old one is + * empty, copy over the fields from the new one. Won't this result in + * all sorts of undefined types??? *) + if old_len = 0 then + oldci.cfields <- ci.cfields; + end; + (* We get here when we succeeded checking that they are equal, or one of + * them was empty *) + newrep.ndata.cattr <- addAttributes oldci.cattr ci.cattr; + () + end + +(* Match two enuminfos and throw a Failure if they do not match *) +and matchEnumInfo (oldfidx: int) (oldei: enuminfo) + (fidx: int) (ei: enuminfo) : unit = + (* Find the node for this enum, no path compression. *) + let oldeinode = getNode eEq eSyn oldfidx oldei.ename oldei None in + let einode = getNode eEq eSyn fidx ei.ename ei None in + if oldeinode == einode then (* We already know they are the same *) + () + else begin + (* Replace with the representative data *) + let oldei = oldeinode.ndata in + let ei = einode.ndata in + (* Try to match them. But if you cannot just make them both integers *) + try + (* We do not have a mapping. They better be defined in the same way *) + if List.length oldei.eitems <> List.length ei.eitems then + raise (Failure "(different number of enumeration elements)"); + (* We check that they are defined in the same way. This is a fairly + * conservative check. *) + List.iter2 + (fun (old_iname, old_iv, _) (iname, iv, _) -> + if old_iname <> iname then + raise (Failure "(different names for enumeration items)"); + let samev = + match constFold true old_iv, constFold true iv with + Const(CInt64(oldi, _, _)), Const(CInt64(i, _, _)) -> oldi = i + | _ -> false + in + if not samev then + raise (Failure "(different values for enumeration items)")) + oldei.eitems ei.eitems; + (* Set the representative *) + let newrep, _ = union oldeinode einode in + (* We get here if the enumerations match *) + newrep.ndata.eattr <- addAttributes oldei.eattr ei.eattr; + () + with Failure msg -> begin + (* Get here if you cannot merge two enumeration nodes *) + if oldeinode != intEnumInfoNode then begin + let _ = union oldeinode intEnumInfoNode in () + end; + if einode != intEnumInfoNode then begin + let _ = union einode intEnumInfoNode in () + end; + end + end + + +(* Match two typeinfos and throw a Failure if they do not match *) +and matchTypeInfo (oldfidx: int) (oldti: typeinfo) + (fidx: int) (ti: typeinfo) : unit = + if oldti.tname = "" || ti.tname = "" then + E.s (bug "matchTypeInfo for anonymous type\n"); + (* Find the node for this enum, no path compression. *) + let oldtnode = getNode tEq tSyn oldfidx oldti.tname oldti None in + let tnode = getNode tEq tSyn fidx ti.tname ti None in + if oldtnode == tnode then (* We already know they are the same *) + () + else begin + (* Replace with the representative data *) + let oldti = oldtnode.ndata in + let oldfidx = oldtnode.nfidx in + let ti = tnode.ndata in + let fidx = tnode.nfidx in + (* Check that they are the same *) + (try + ignore (combineTypes CombineOther oldfidx oldti.ttype fidx ti.ttype); + with Failure reason -> begin + let msg = + P.sprint ~width:80 + (P.dprintf + "\n\tFailed assumption that %s and %s are isomorphic %s" + oldti.tname ti.tname reason) in + raise (Failure msg) + end); + let _ = union oldtnode tnode in + () + end + +(* Scan all files and do two things *) +(* 1. Initialize the alpha renaming tables with the names of the globals so + * that when we come in the second pass to generate new names, we do not run + * into conflicts. *) +(* 2. For all declarations of globals unify their types. In the process + * construct a set of equivalence classes on type names, structure and + * enumeration tags *) +(* 3. We clean the referenced flags *) + +let rec oneFilePass1 (f:file) : unit = + H.add fileNames !currentFidx f.fileName; + if debugMerge || !E.verboseFlag then + ignore (E.log "Pre-merging (%d) %s\n" !currentFidx f.fileName); + currentDeclIdx := 0; + if f.globinitcalled || f.globinit <> None then + E.s (E.warn "Merging file %s has global initializer" f.fileName); + + (* We scan each file and we look at all global varinfo. We see if globals + * with the same name have been encountered before and we merge those types + * *) + let matchVarinfo (vi: varinfo) (l: location * int) = + ignore (Alpha.registerAlphaName vtAlpha None vi.vname !currentLoc); + (* Make a node for it and put it in vEq *) + let vinode = mkSelfNode vEq vSyn !currentFidx vi.vname vi (Some l) in + try + let oldvinode = find true (H.find vEnv vi.vname) in + let oldloc, _ = + match oldvinode.nloc with + None -> E.s (bug "old variable is undefined") + | Some l -> l + in + let oldvi = oldvinode.ndata in + (* There is an old definition. We must combine the types. Do this first + * because it might fail *) + let newtype = + try + combineTypes CombineOther + oldvinode.nfidx oldvi.vtype + !currentFidx vi.vtype; + with (Failure reason) -> begin + (* Go ahead *) + let f = if !ignore_merge_conflicts then warn else error in + ignore (f "Incompatible declaration for %s (from %s(%d)).@! Previous was at %a (from %s (%d)) %s " + vi.vname (H.find fileNames !currentFidx) !currentFidx + d_loc oldloc + (H.find fileNames oldvinode.nfidx) oldvinode.nfidx + reason); + raise Not_found + end + in + let newrep, _ = union oldvinode vinode in + (* We do not want to turn non-"const" globals into "const" one. That + * can happen if one file declares the variable a non-const while + * others declare it as "const". *) + if hasAttribute "const" (typeAttrs vi.vtype) != + hasAttribute "const" (typeAttrs oldvi.vtype) then begin + newrep.ndata.vtype <- typeRemoveAttributes ["const"] newtype; + end else begin + newrep.ndata.vtype <- newtype; + end; + (* clean up the storage. *) + let newstorage = + if vi.vstorage = oldvi.vstorage || vi.vstorage = Extern then + oldvi.vstorage + else if oldvi.vstorage = Extern then vi.vstorage + (* Sometimes we turn the NoStorage specifier into Static for inline + * functions *) + else if oldvi.vstorage = Static && + vi.vstorage = NoStorage then Static + else begin + ignore (warn "Inconsistent storage specification for %s. Now is %a and previous was %a at %a" + vi.vname d_storage vi.vstorage d_storage oldvi.vstorage + d_loc oldloc); + vi.vstorage + end + in + newrep.ndata.vstorage <- newstorage; + newrep.ndata.vattr <- addAttributes oldvi.vattr vi.vattr; + () + with Not_found -> (* Not present in the previous files. Remember it for + * later *) + H.add vEnv vi.vname vinode + + in + List.iter + (function + | GVarDecl (vi, l) | GVar (vi, _, l) -> + currentLoc := l; + incr currentDeclIdx; + vi.vreferenced <- false; + if vi.vstorage <> Static then begin + matchVarinfo vi (l, !currentDeclIdx); + end + + | GFun (fdec, l) -> + currentLoc := l; + incr currentDeclIdx; + (* Save the names of the formal arguments *) + let _, args, _, _ = splitFunctionTypeVI fdec.svar in + H.add formalNames (!currentFidx, fdec.svar.vname) + (List.map (fun (fn, _, _) -> fn) (argsToList args)); + fdec.svar.vreferenced <- false; + (* Force inline functions to be static. *) + (* GN: This turns out to be wrong. inline functions are external, + * unless specified to be static. *) + (* + if fdec.svar.vinline && fdec.svar.vstorage = NoStorage then + fdec.svar.vstorage <- Static; + *) + if fdec.svar.vstorage <> Static then begin + matchVarinfo fdec.svar (l, !currentDeclIdx) + end else begin + if fdec.svar.vinline && mergeInlines then + (* Just create the nodes for inline functions *) + ignore (getNode iEq iSyn !currentFidx + fdec.svar.vname fdec.svar (Some (l, !currentDeclIdx))) + end + (* Make nodes for the defined type and structure tags *) + | GType (t, l) -> + incr currentDeclIdx; + t.treferenced <- false; + if t.tname <> "" then (* The empty names are just for introducing + * undefined comp tags *) + ignore (getNode tEq tSyn !currentFidx t.tname t + (Some (l, !currentDeclIdx))) + else begin (* Go inside and clean the referenced flag for the + * declared tags *) + match t.ttype with + TComp (ci, _) -> + ci.creferenced <- false; + (* Create a node for it *) + ignore (getNode sEq sSyn !currentFidx ci.cname ci None) + + | TEnum (ei, _) -> + ei.ereferenced <- false; + ignore (getNode eEq eSyn !currentFidx ei.ename ei None); + + | _ -> E.s (bug "Anonymous Gtype is not TComp") + end + + | GCompTag (ci, l) -> + incr currentDeclIdx; + ci.creferenced <- false; + ignore (getNode sEq sSyn !currentFidx ci.cname ci + (Some (l, !currentDeclIdx))) + | GEnumTag (ei, l) -> + incr currentDeclIdx; + ei.ereferenced <- false; + ignore (getNode eEq eSyn !currentFidx ei.ename ei + (Some (l, !currentDeclIdx))) + + | _ -> ()) + f.globals + + +(* Try to merge synonyms. Do not give an error if they fail to merge *) +let doMergeSynonyms + (syn : (string, 'a node) H.t) + (eq : (int * string, 'a node) H.t) + (compare : int -> 'a -> int -> 'a -> unit) (* A comparison function that + * throws Failure if no match *) + : unit = + H.iter (fun n node -> + if not node.nmergedSyns then begin + (* find all the nodes for the same name *) + let all = H.find_all syn n in + let rec tryone (classes: 'a node list) (* A number of representatives + * for this name *) + (nd: 'a node) : 'a node list (* Returns an expanded set + * of classes *) = + nd.nmergedSyns <- true; + (* Compare in turn with all the classes we have so far *) + let rec compareWithClasses = function + [] -> [nd](* No more classes. Add this as a new class *) + | c :: restc -> + try + compare c.nfidx c.ndata nd.nfidx nd.ndata; + (* Success. Stop here the comparison *) + c :: restc + with Failure _ -> (* Failed. Try next class *) + c :: (compareWithClasses restc) + in + compareWithClasses classes + in + (* Start with an empty set of classes for this name *) + let _ = List.fold_left tryone [] all in + () + end) + syn + + +let matchInlines (oldfidx: int) (oldi: varinfo) + (fidx: int) (i: varinfo) = + let oldinode = getNode iEq iSyn oldfidx oldi.vname oldi None in + let inode = getNode iEq iSyn fidx i.vname i None in + if oldinode == inode then + () + else begin + (* Replace with the representative data *) + let oldi = oldinode.ndata in + let oldfidx = oldinode.nfidx in + let i = inode.ndata in + let fidx = inode.nfidx in + (* There is an old definition. We must combine the types. Do this first + * because it might fail *) + oldi.vtype <- + combineTypes CombineOther + oldfidx oldi.vtype fidx i.vtype; + (* We get here if we have success *) + (* Combine the attributes as well *) + oldi.vattr <- addAttributes oldi.vattr i.vattr; + (* Do not union them yet because we do not know that they are the same. + * We have checked only the types so far *) + () + end + +(************************************************************ + * + * PASS 2 + * + * + ************************************************************) + +(** Keep track of the functions we have used already in the file. We need + * this to avoid removing an inline function that has been used already. + * This can only occur if the inline function is defined after it is used + * already; a bad style anyway *) +let varUsedAlready: (string, unit) H.t = H.create 111 + +(** A visitor that renames uses of variables and types *) +class renameVisitorClass = object (self) + inherit nopCilVisitor + + (* This is either a global variable which we took care of, or a local + * variable. Must do its type and attributes. *) + method vvdec (vi: varinfo) = DoChildren + + (* This is a variable use. See if we must change it *) + method vvrbl (vi: varinfo) : varinfo visitAction = + if not vi.vglob then DoChildren else + if vi.vreferenced then begin + H.add varUsedAlready vi.vname (); + DoChildren + end else begin + match findReplacement true vEq !currentFidx vi.vname with + None -> DoChildren + | Some (vi', oldfidx) -> + if debugMerge then + ignore (E.log "Renaming use of var %s(%d) to %s(%d)\n" + vi.vname !currentFidx vi'.vname oldfidx); + vi'.vreferenced <- true; + H.add varUsedAlready vi'.vname (); + ChangeTo vi' + end + + + (* The use of a type. Change only those types whose underlying info + * is not a root. *) + method vtype (t: typ) = + match t with + TComp (ci, a) when not ci.creferenced -> begin + match findReplacement true sEq !currentFidx ci.cname with + None -> DoChildren + | Some (ci', oldfidx) -> + if debugMerge then + ignore (E.log "Renaming use of %s(%d) to %s(%d)\n" + ci.cname !currentFidx ci'.cname oldfidx); + ChangeTo (TComp (ci', visitCilAttributes (self :> cilVisitor) a)) + end + | TEnum (ei, a) when not ei.ereferenced -> begin + match findReplacement true eEq !currentFidx ei.ename with + None -> DoChildren + | Some (ei', _) -> + if ei' == intEnumInfo then + (* This is actually our friend intEnumInfo *) + ChangeTo (TInt(IInt, visitCilAttributes (self :> cilVisitor) a)) + else + ChangeTo (TEnum (ei', visitCilAttributes (self :> cilVisitor) a)) + end + + | TNamed (ti, a) when not ti.treferenced -> begin + match findReplacement true tEq !currentFidx ti.tname with + None -> DoChildren + | Some (ti', _) -> + ChangeTo (TNamed (ti', visitCilAttributes (self :> cilVisitor) a)) + end + + | _ -> DoChildren + + (* The Field offset might need to be changed to use new compinfo *) + method voffs = function + Field (f, o) -> begin + (* See if the compinfo was changed *) + if f.fcomp.creferenced then + DoChildren + else begin + match findReplacement true sEq !currentFidx f.fcomp.cname with + None -> DoChildren (* We did not replace it *) + | Some (ci', oldfidx) -> begin + (* First, find out the index of the original field *) + let rec indexOf (i: int) = function + [] -> + E.s (bug "Cannot find field %s in %s(%d)\n" + f.fname (compFullName f.fcomp) !currentFidx) + | f' :: rest when f' == f -> i + | _ :: rest -> indexOf (i + 1) rest + in + let index = indexOf 0 f.fcomp.cfields in + if List.length ci'.cfields <= index then + E.s (bug "Too few fields in replacement %s(%d) for %s(%d)\n" + (compFullName ci') oldfidx + (compFullName f.fcomp) !currentFidx); + let f' = List.nth ci'.cfields index in + ChangeDoChildrenPost (Field (f', o), fun x -> x) + end + end + end + | _ -> DoChildren + + method vinitoffs o = + (self#voffs o) (* treat initializer offsets same as lvalue offsets *) + +end + +let renameVisitor = new renameVisitorClass + + +(** A visitor that renames uses of inline functions that were discovered in + * pass 2 to be used before they are defined. This is like the renameVisitor + * except it only looks at the variables (thus it is a bit more efficient) + * and it also renames forward declarations of the inlines to be removed. *) + +class renameInlineVisitorClass = object (self) + inherit nopCilVisitor + + (* This is a variable use. See if we must change it *) + method vvrbl (vi: varinfo) : varinfo visitAction = + if not vi.vglob then DoChildren else + if vi.vreferenced then begin (* Already renamed *) + DoChildren + end else begin + match findReplacement true vEq !currentFidx vi.vname with + None -> DoChildren + | Some (vi', oldfidx) -> + if debugMerge then + ignore (E.log "Renaming var %s(%d) to %s(%d)\n" + vi.vname !currentFidx vi'.vname oldfidx); + vi'.vreferenced <- true; + ChangeTo vi' + end + + (* And rename some declarations of inlines to remove. We cannot drop this + * declaration (see small1/combineinline6) *) + method vglob = function + GVarDecl(vi, l) when vi.vinline -> begin + (* Get the original name *) + let origname = + try H.find originalVarNames vi.vname + with Not_found -> vi.vname + in + (* Now see if this must be replaced *) + match findReplacement true vEq !currentFidx origname with + None -> DoChildren + | Some (vi', _) -> ChangeTo [GVarDecl (vi', l)] + end + | _ -> DoChildren + +end +let renameInlinesVisitor = new renameInlineVisitorClass + + +(* sm: First attempt at a semantic checksum for function bodies. + * Ideally, two function's checksums would be equal only when their + * bodies were provably equivalent; but I'm using a much simpler and + * less accurate heuristic here. It should be good enough for the + * purpose I have in mind, which is doing duplicate removal of + * multiply-instantiated template functions. *) +let functionChecksum (dec: fundec) : int = +begin + (* checksum the structure of the statements (only) *) + let rec stmtListSum (lst : stmt list) : int = + (List.fold_left (fun acc s -> acc + (stmtSum s)) 0 lst) + and stmtSum (s: stmt) : int = + (* strategy is to just throw a lot of prime numbers into the + * computation in hopes of avoiding accidental collision.. *) + match s.skind with + | Instr(l) -> 13 + 67*(List.length l) + | Return(_) -> 17 + | Goto(_) -> 19 + | Break(_) -> 23 + | Continue(_) -> 29 + | If(_,b1,b2,_) -> 31 + 37*(stmtListSum b1.bstmts) + + 41*(stmtListSum b2.bstmts) + | Switch(_,b,_,_) -> 43 + 47*(stmtListSum b.bstmts) + (* don't look at stmt list b/c is not part of tree *) +(* + | Loop(b,_,_,_) -> 49 + 53*(stmtListSum b.bstmts) +*) + | While(_,b,_) -> 49 + 53*(stmtListSum b.bstmts) + | DoWhile(_,b,_) -> 49 + 53*(stmtListSum b.bstmts) + | For(_,_,_,b,_) -> 49 + 53*(stmtListSum b.bstmts) + | Block(b) -> 59 + 61*(stmtListSum b.bstmts) + | TryExcept (b, (il, e), h, _) -> + 67 + 83*(stmtListSum b.bstmts) + 97*(stmtListSum h.bstmts) + | TryFinally (b, h, _) -> + 103 + 113*(stmtListSum b.bstmts) + 119*(stmtListSum h.bstmts) + in + + (* disabled 2nd and 3rd measure because they appear to get different + * values, for the same code, depending on whether the code was just + * parsed into CIL or had previously been parsed into CIL, printed + * out, then re-parsed into CIL *) + let a,b,c,d,e = + (List.length dec.sformals), (* # formals *) + 0 (*(List.length dec.slocals)*), (* # locals *) + 0 (*dec.smaxid*), (* estimate of internal statement count *) + (List.length dec.sbody.bstmts), (* number of statements at outer level *) + (stmtListSum dec.sbody.bstmts) in (* checksum of statement structure *) + (*(trace "sm" (P.dprintf "sum: %s is %d %d %d %d %d\n"*) + (* dec.svar.vname a b c d e));*) + 2*a + 3*b + 5*c + 7*d + 11*e +end + + +(* sm: equality for initializers, etc.; this is like '=', except + * when we reach shared pieces (like references into the type + * structure), we use '==', to prevent circularity *) +(* update: that's no good; I'm using this to find things which + * are equal but from different CIL trees, so nothing will ever + * be '=='.. as a hack I'll just change those places to 'true', + * so these functions are not now checking proper equality.. + * places where equality is not complete are marked "INC" *) +let rec equalInits (x: init) (y: init) : bool = +begin + match x,y with + | SingleInit(xe), SingleInit(ye) -> (equalExps xe ye) + | CompoundInit(xt, xoil), CompoundInit(yt, yoil) -> + (*(xt == yt) &&*) (* INC *) (* types need to be identically equal *) + let rec equalLists xoil yoil : bool = + match xoil,yoil with + | ((xo,xi) :: xrest), ((yo,yi) :: yrest) -> + (equalOffsets xo yo) && + (equalInits xi yi) && + (equalLists xrest yrest) + | [], [] -> true + | _, _ -> false + in + (equalLists xoil yoil) + | _, _ -> false +end + +and equalOffsets (x: offset) (y: offset) : bool = +begin + match x,y with + | NoOffset, NoOffset -> true + | Field(xfi,xo), Field(yfi,yo) -> + (xfi.fname = yfi.fname) && (* INC: same fieldinfo name.. *) + (equalOffsets xo yo) + | Index(xe,xo), Index(ye,yo) -> + (equalExps xe ye) && + (equalOffsets xo yo) + | _,_ -> false +end + +and equalExps (x: exp) (y: exp) : bool = +begin + match x,y with + | Const(xc), Const(yc) -> xc = yc || (* safe to use '=' on literals *) + ( + (* CIL changes (unsigned)0 into 0U during printing.. *) + match xc,yc with + | CInt64(xv,_,_),CInt64(yv,_,_) -> + (Int64.to_int xv) = 0 && (* ok if they're both 0 *) + (Int64.to_int yv) = 0 + | _,_ -> false + ) + | Lval(xl), Lval(yl) -> (equalLvals xl yl) + | SizeOf(xt), SizeOf(yt) -> true (*INC: xt == yt*) (* identical types *) + | SizeOfE(xe), SizeOfE(ye) -> (equalExps xe ye) + | AlignOf(xt), AlignOf(yt) -> true (*INC: xt == yt*) + | AlignOfE(xe), AlignOfE(ye) -> (equalExps xe ye) + | UnOp(xop,xe,xt), UnOp(yop,ye,yt) -> + xop = yop && + (equalExps xe ye) && + true (*INC: xt == yt*) + | BinOp(xop,xe1,xe2,xt), BinOp(yop,ye1,ye2,yt) -> + xop = yop && + (equalExps xe1 ye1) && + (equalExps xe2 ye2) && + true (*INC: xt == yt*) + | CastE(xt,xe), CastE(yt,ye) -> + (*INC: xt == yt &&*) + (equalExps xe ye) + | AddrOf(xl), AddrOf(yl) -> (equalLvals xl yl) + | StartOf(xl), StartOf(yl) -> (equalLvals xl yl) + + (* initializers that go through CIL multiple times sometimes lose casts they + * had the first time; so allow a different of a cast *) + | CastE(xt,xe), ye -> + (equalExps xe ye) + | xe, CastE(yt,ye) -> + (equalExps xe ye) + + | _,_ -> false +end + +and equalLvals (x: lval) (y: lval) : bool = +begin + match x,y with + | (Var(xv),xo), (Var(yv),yo) -> + (* I tried, I really did.. the problem is I see these names + * before merging collapses them, so __T123 != __T456, + * so whatever *) + (*(xv.vname = vy.vname) && (* INC: same varinfo names.. *)*) + (equalOffsets xo yo) + + | (Mem(xe),xo), (Mem(ye),yo) -> + (equalExps xe ye) && + (equalOffsets xo yo) + | _,_ -> false +end + +let equalInitOpts (x: init option) (y: init option) : bool = +begin + match x,y with + | None,None -> true + | Some(xi), Some(yi) -> (equalInits xi yi) + | _,_ -> false +end + + + (* Now we go once more through the file and we rename the globals that we + * keep. We also scan the entire body and we replace references to the + * representative types or variables. We set the referenced flags once we + * have replaced the names. *) +let oneFilePass2 (f: file) = + if debugMerge || !E.verboseFlag then + ignore (E.log "Final merging phase (%d): %s\n" + !currentFidx f.fileName); + currentDeclIdx := 0; (* Even though we don't need it anymore *) + H.clear varUsedAlready; + H.clear originalVarNames; + (* If we find inline functions that are used before being defined, and thus + * before knowing that we can throw them away, then we mark this flag so + * that we can make another pass over the file *) + let repeatPass2 = ref false in + (* Keep a pointer to the contents of the file so far *) + let savedTheFile = !theFile in + + let processOneGlobal (g: global) : unit = + (* Process a varinfo. Reuse an old one, or rename it if necessary *) + let processVarinfo (vi: varinfo) (vloc: location) : varinfo = + if vi.vreferenced then + vi (* Already done *) + else begin + (* Maybe it is static. Rename it then *) + if vi.vstorage = Static then begin + let newName, _ = A.newAlphaName vtAlpha None vi.vname !currentLoc in + (* Remember the original name *) + H.add originalVarNames newName vi.vname; + if debugMerge then ignore (E.log "renaming %s at %a to %s\n" + vi.vname d_loc vloc newName); + vi.vname <- newName; + vi.vid <- newVID (); + vi.vreferenced <- true; + vi + end else begin + (* Find the representative *) + match findReplacement true vEq !currentFidx vi.vname with + None -> vi (* This is the representative *) + | Some (vi', _) -> (* Reuse some previous one *) + vi'.vreferenced <- true; (* Mark it as done already *) + vi'.vaddrof <- vi.vaddrof || vi'.vaddrof; + vi' + end + end + in + try + match g with + | GVarDecl (vi, l) as g -> + currentLoc := l; + incr currentDeclIdx; + let vi' = processVarinfo vi l in + if vi != vi' then (* Drop this declaration *) () + else if H.mem emittedVarDecls vi'.vname then (* No need to keep it *) + () + else begin + H.add emittedVarDecls vi'.vname true; (* Remember that we emitted + * it *) + mergePushGlobals (visitCilGlobal renameVisitor g) + end + + | GVar (vi, init, l) -> + currentLoc := l; + incr currentDeclIdx; + let vi' = processVarinfo vi l in + (* We must keep this definition even if we reuse this varinfo, + * because maybe the previous one was a declaration *) + H.add emittedVarDecls vi.vname true; (* Remember that we emitted it*) + + let emitIt:bool = (not mergeGlobals) || + try + let prevVar, prevInitOpt, prevLoc = + (H.find emittedVarDefn vi'.vname) in + (* previously defined; same initializer? *) + if (equalInitOpts prevInitOpt init.init) + || (init.init = None) then ( + (trace "mergeGlob" + (P.dprintf "dropping global var %s at %a in favor of the one at %a\n" + vi'.vname d_loc l d_loc prevLoc)); + false (* do not emit *) + ) + else if prevInitOpt = None then ( + (* We have an initializer, but the previous one didn't. + We should really convert the previous global from GVar + to GVarDecl, but that's not convenient to do here. *) + true + ) + else ( + (* Both GVars have initializers. *) + (E.s (error "global var %s at %a has different initializer than %a\n" + vi'.vname d_loc l d_loc prevLoc)); + ) + with Not_found -> ( + (* no previous definition *) + (H.add emittedVarDefn vi'.vname (vi', init.init, l)); + true (* emit it *) + ) + in + + if emitIt then + mergePushGlobals (visitCilGlobal renameVisitor (GVar(vi', init, l))) + + | GFun (fdec, l) as g -> + currentLoc := l; + incr currentDeclIdx; + (* We apply the renaming *) + fdec.svar <- processVarinfo fdec.svar l; + (* Get the original name. *) + let origname = + try H.find originalVarNames fdec.svar.vname + with Not_found -> fdec.svar.vname + in + (* Go in there and rename everything as needed *) + let fdec' = + match visitCilGlobal renameVisitor g with + [GFun(fdec', _)] -> fdec' + | _ -> E.s (unimp "renameVisitor for GFun returned something else") + in + let g' = GFun(fdec', l) in + (* Now restore the parameter names *) + let _, args, _, _ = splitFunctionTypeVI fdec'.svar in + let oldnames, foundthem = + try H.find formalNames (!currentFidx, origname), true + with Not_found -> begin + ignore (warnOpt "Cannot find %s in formalNames" origname); + [], false + end + in + if foundthem then begin + let argl = argsToList args in + if List.length oldnames <> List.length argl then + E.s (unimp "After merging the function has more arguments"); + List.iter2 + (fun oldn a -> if oldn <> "" then a.vname <- oldn) + oldnames fdec.sformals; + (* Reflect them in the type *) + setFormals fdec fdec.sformals + end; + (** See if we can remove this inline function *) + if fdec'.svar.vinline && mergeInlines then begin + let printout = + (* Temporarily turn of printing of lines *) + let oldprintln = !lineDirectiveStyle in + lineDirectiveStyle := None; + (* Temporarily set the name to all functions in the same way *) + let newname = fdec'.svar.vname in + fdec'.svar.vname <- "@@alphaname@@"; + (* If we must do alpha conversion then temporarily set the + * names of the local variables and formals in a standard way *) + let nameId = ref 0 in + let oldNames : string list ref = ref [] in + let renameOne (v: varinfo) = + oldNames := v.vname :: !oldNames; + incr nameId; + v.vname <- "___alpha" ^ string_of_int !nameId + in + let undoRenameOne (v: varinfo) = + match !oldNames with + n :: rest -> + oldNames := rest; + v.vname <- n + | _ -> E.s (bug "undoRenameOne") + in + (* Remember the original type *) + let origType = fdec'.svar.vtype in + if mergeInlinesWithAlphaConvert then begin + (* Rename the formals *) + List.iter renameOne fdec'.sformals; + (* Reflect in the type *) + setFormals fdec' fdec'.sformals; + (* Now do the locals *) + List.iter renameOne fdec'.slocals + end; + (* Now print it *) + let res = d_global () g' in + lineDirectiveStyle := oldprintln; + fdec'.svar.vname <- newname; + if mergeInlinesWithAlphaConvert then begin + (* Do the locals in reverse order *) + List.iter undoRenameOne (List.rev fdec'.slocals); + (* Do the formals in reverse order *) + List.iter undoRenameOne (List.rev fdec'.sformals); + (* Restore the type *) + fdec'.svar.vtype <- origType; + end; + res + in + (* Make a node for this inline function using the original name. *) + let inode = + getNode vEq vSyn !currentFidx origname fdec'.svar + (Some (l, !currentDeclIdx)) + in + if debugInlines then begin + ignore (E.log "getNode %s(%d) with loc=%a. declidx=%d\n" + inode.nname inode.nfidx + d_nloc inode.nloc + !currentDeclIdx); + ignore (E.log + "Looking for previous definition of inline %s(%d)\n" + origname !currentFidx); + end; + try + let oldinode = H.find inlineBodies printout in + if debugInlines then + ignore (E.log " Matches %s(%d)\n" + oldinode.nname oldinode.nfidx); + (* There is some other inline function with the same printout. + * We should reuse this, but watch for the case when the inline + * was already used. *) + if H.mem varUsedAlready fdec'.svar.vname then begin + if mergeInlinesRepeat then begin + repeatPass2 := true + end else begin + ignore (warn "Inline function %s because it is used before it is defined" fdec'.svar.vname); + raise Not_found + end + end; + let _ = union oldinode inode in + (* Clean up the vreferenced bit in the new inline, so that we + * can rename it. Reset the name to the original one so that + * we can find the replacement name. *) + fdec'.svar.vreferenced <- false; + fdec'.svar.vname <- origname; + () (* Drop this definition *) + with Not_found -> begin + if debugInlines then ignore (E.log " Not found\n"); + H.add inlineBodies printout inode; + mergePushGlobal g' + end + end else begin + (* either the function is not inline, or we're not attempting to + * merge inlines *) + if (mergeGlobals && + not fdec'.svar.vinline && + fdec'.svar.vstorage <> Static) then + begin + (* sm: this is a non-inline, non-static function. I want to + * consider dropping it if a same-named function has already + * been put into the merged file *) + let curSum = (functionChecksum fdec') in + (*(trace "mergeGlob" (P.dprintf "I see extern function %s, sum is %d\n"*) + (* fdec'.svar.vname curSum));*) + try + let prevFun, prevLoc, prevSum = + (H.find emittedFunDefn fdec'.svar.vname) in + (* previous was found *) + if (curSum = prevSum) then + (trace "mergeGlob" + (P.dprintf "dropping duplicate def'n of func %s at %a in favor of that at %a\n" + fdec'.svar.vname d_loc l d_loc prevLoc)) + else begin + (* the checksums differ, so print a warning but keep the + * older one to avoid a link error later. I think this is + * a reasonable approximation of what ld does. *) + (ignore (warn "def'n of func %s at %a (sum %d) conflicts with the one at %a (sum %d); keeping the one at %a.\n" + fdec'.svar.vname d_loc l curSum d_loc prevLoc + prevSum d_loc prevLoc)) + end + with Not_found -> begin + (* there was no previous definition *) + (mergePushGlobal g'); + (H.add emittedFunDefn fdec'.svar.vname (fdec', l, curSum)) + end + end else begin + (* not attempting to merge global functions, or it was static + * or inline *) + mergePushGlobal g' + end + end + + | GCompTag (ci, l) as g -> begin + currentLoc := l; + incr currentDeclIdx; + if ci.creferenced then + () + else begin + match findReplacement true sEq !currentFidx ci.cname with + None -> + (* A new one, we must rename it and keep the definition *) + (* Make sure this is root *) + (try + let nd = H.find sEq (!currentFidx, ci.cname) in + if nd.nrep != nd then + E.s (bug "Setting creferenced for struct %s(%d) which is not root!\n" + ci.cname !currentFidx); + with Not_found -> begin + E.s (bug "Setting creferenced for struct %s(%d) which is not in the sEq!\n" + ci.cname !currentFidx); + end); + let newname, _ = + A.newAlphaName sAlpha None ci.cname !currentLoc in + ci.cname <- newname; + ci.creferenced <- true; + ci.ckey <- H.hash (compFullName ci); + (* Now we should visit the fields as well *) + H.add emittedCompDecls ci.cname true; (* Remember that we + * emitted it *) + mergePushGlobals (visitCilGlobal renameVisitor g) + | Some (oldci, oldfidx) -> begin + (* We are not the representative. Drop this declaration + * because we'll not be using it. *) + () + end + end + end + | GEnumTag (ei, l) as g -> begin + currentLoc := l; + incr currentDeclIdx; + if ei.ereferenced then + () + else begin + match findReplacement true eEq !currentFidx ei.ename with + None -> (* We must rename it *) + let newname, _ = + A.newAlphaName eAlpha None ei.ename !currentLoc in + ei.ename <- newname; + ei.ereferenced <- true; + (* And we must rename the items to using the same name space + * as the variables *) + ei.eitems <- + List.map + (fun (n, i, loc) -> + let newname, _ = + A.newAlphaName vtAlpha None n !currentLoc in + newname, i, loc) + ei.eitems; + mergePushGlobals (visitCilGlobal renameVisitor g); + | Some (ei', _) -> (* Drop this since we are reusing it from + * before *) + () + end + end + | GCompTagDecl (ci, l) -> begin + currentLoc := l; (* This is here just to introduce an undefined + * structure. But maybe the structure was defined + * already. *) + (* Do not increment currentDeclIdx because it is not incremented in + * pass 1*) + if H.mem emittedCompDecls ci.cname then + () (* It was already declared *) + else begin + H.add emittedCompDecls ci.cname true; + (* Keep it as a declaration *) + mergePushGlobal g; + end + end + + | GEnumTagDecl (ei, l) -> + currentLoc := l; + (* Do not increment currentDeclIdx because it is not incremented in + * pass 1*) + (* Keep it as a declaration *) + mergePushGlobal g + + + | GType (ti, l) as g -> begin + currentLoc := l; + incr currentDeclIdx; + if ti.treferenced then + () + else begin + match findReplacement true tEq !currentFidx ti.tname with + None -> (* We must rename it and keep it *) + let newname, _ = + A.newAlphaName vtAlpha None ti.tname !currentLoc in + ti.tname <- newname; + ti.treferenced <- true; + mergePushGlobals (visitCilGlobal renameVisitor g); + | Some (ti', _) ->(* Drop this since we are reusing it from + * before *) + () + end + end + | g -> mergePushGlobals (visitCilGlobal renameVisitor g) + with e -> begin + let globStr:string = (P.sprint 1000 (P.dprintf + "error when merging global %a: %s" + d_global g (Printexc.to_string e))) in + ignore (E.log "%s\n" globStr); + (*"error when merging global: %s\n" (Printexc.to_string e);*) + mergePushGlobal (GText (P.sprint 80 + (P.dprintf "/* error at %t:" d_thisloc))); + mergePushGlobal g; + mergePushGlobal (GText ("*************** end of error*/")); + raise e + end + in + (* Now do the real PASS 2 *) + List.iter processOneGlobal f.globals; + (* See if we must re-visit the globals in this file because an inline that + * is being removed was used before we saw the definition and we decided to + * remove it *) + if mergeInlinesRepeat && !repeatPass2 then begin + if debugMerge || !E.verboseFlag then + ignore (E.log "Repeat final merging phase (%d): %s\n" + !currentFidx f.fileName); + (* We are going to rescan the globals we have added while processing this + * file. *) + let theseGlobals : global list ref = ref [] in + (* Scan a list of globals until we hit a given tail *) + let rec scanUntil (tail: 'a list) (l: 'a list) = + if tail == l then () + else + match l with + | [] -> E.s (bug "mergecil: scanUntil could not find the marker\n") + | g :: rest -> + theseGlobals := g :: !theseGlobals; + scanUntil tail rest + in + (* Collect in theseGlobals all the globals from this file *) + theseGlobals := []; + scanUntil savedTheFile !theFile; + (* Now reprocess them *) + theFile := savedTheFile; + List.iter (fun g -> + theFile := (visitCilGlobal renameInlinesVisitor g) @ !theFile) + !theseGlobals; + (* Now check if we have inlines that we could not remove + H.iter (fun name _ -> + if not (H.mem inlinesRemoved name) then + ignore (warn "Could not remove inline %s. I have no idea why!\n" + name)) + inlinesToRemove *) + end + + +let merge (files: file list) (newname: string) : file = + init (); + + (* Make the first pass over the files *) + currentFidx := 0; + List.iter (fun f -> oneFilePass1 f; incr currentFidx) files; + + (* Now maybe try to force synonyms to be equal *) + if mergeSynonyms then begin + doMergeSynonyms sSyn sEq matchCompInfo; + doMergeSynonyms eSyn eEq matchEnumInfo; + doMergeSynonyms tSyn tEq matchTypeInfo; + if mergeInlines then begin + (* Copy all the nodes from the iEq to vEq as well. This is needed + * because vEq will be used for variable renaming *) + H.iter (fun k n -> H.add vEq k n) iEq; + doMergeSynonyms iSyn iEq matchInlines; + end + end; + + (* Now maybe dump the graph *) + if debugMerge then begin + dumpGraph "type" tEq; + dumpGraph "struct and union" sEq; + dumpGraph "enum" eEq; + dumpGraph "variable" vEq; + if mergeInlines then dumpGraph "inline" iEq; + end; + (* Make the second pass over the files. This is when we start rewriting the + * file *) + currentFidx := 0; + List.iter (fun f -> oneFilePass2 f; incr currentFidx) files; + + (* Now reverse the result and return the resulting file *) + let rec revonto acc = function + [] -> acc + | x :: t -> revonto (x :: acc) t + in + let res = + { fileName = newname; + globals = revonto (revonto [] !theFile) !theFileTypes; + globinit = None; + globinitcalled = false;} in + init (); (* Make the GC happy *) + (* We have made many renaming changes and sometimes we have just guessed a + * name wrong. Make sure now that the local names are unique. *) + uniqueVarNames res; + res + + + + + diff --git a/cil/src/mergecil.mli b/cil/src/mergecil.mli new file mode 100644 index 0000000..a864c69 --- /dev/null +++ b/cil/src/mergecil.mli @@ -0,0 +1,42 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(** Set this to true to ignore the merge conflicts *) +val ignore_merge_conflicts: bool ref + +(** Merge a number of CIL files *) +val merge: Cil.file list -> string -> Cil.file diff --git a/cil/src/rmtmps.ml b/cil/src/rmtmps.ml new file mode 100644 index 0000000..b7dea93 --- /dev/null +++ b/cil/src/rmtmps.ml @@ -0,0 +1,778 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Ben Liblit + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* rmtmps.ml *) +(* implementation for rmtmps.mli *) + +open Pretty +open Cil +module H = Hashtbl +module E = Errormsg +module U = Util + +(* Set on the command-line: *) +let keepUnused = ref false +let rmUnusedInlines = ref false + + +let trace = Trace.trace "rmtmps" + + + +(*********************************************************************** + * + * Clearing of "referenced" bits + * + *) + + +let clearReferencedBits file = + let considerGlobal global = + match global with + | GType (info, _) -> + trace (dprintf "clearing mark: %a\n" d_shortglobal global); + info.treferenced <- false + + | GEnumTag (info, _) + | GEnumTagDecl (info, _) -> + trace (dprintf "clearing mark: %a\n" d_shortglobal global); + info.ereferenced <- false + + | GCompTag (info, _) + | GCompTagDecl (info, _) -> + trace (dprintf "clearing mark: %a\n" d_shortglobal global); + info.creferenced <- false + + | GVar ({vname = name} as info, _, _) + | GVarDecl ({vname = name} as info, _) -> + trace (dprintf "clearing mark: %a\n" d_shortglobal global); + info.vreferenced <- false + + | GFun ({svar = info} as func, _) -> + trace (dprintf "clearing mark: %a\n" d_shortglobal global); + info.vreferenced <- false; + let clearMark local = + trace (dprintf "clearing mark: local %s\n" local.vname); + local.vreferenced <- false + in + List.iter clearMark func.slocals + + | _ -> + () + in + iterGlobals file considerGlobal + + +(*********************************************************************** + * + * Scanning and categorization of pragmas + * + *) + + +(* collections of names of things to keep *) +type collection = (string, unit) H.t +type keepers = { + typedefs : collection; + enums : collection; + structs : collection; + unions : collection; + defines : collection; + } + + +(* rapid transfer of control when we find a malformed pragma *) +exception Bad_pragma + +let ccureddeepcopystring = "ccureddeepcopy" +(* Save this length so we don't recompute it each time. *) +let ccureddeepcopystring_length = String.length ccureddeepcopystring + +(* CIL and CCured define several pragmas which prevent removal of + * various global symbols. Here we scan for those pragmas and build + * up collections of the corresponding symbols' names. + *) + +let categorizePragmas file = + + (* names of things which should be retained *) + let keepers = { + typedefs = H.create 0; + enums = H.create 0; + structs = H.create 0; + unions = H.create 0; + defines = H.create 1 + } in + + (* populate these name collections in light of each pragma *) + let considerPragma = + + let badPragma location pragma = + ignore (warnLoc location "Invalid argument to pragma %s" pragma) + in + + function + | GPragma (Attr ("cilnoremove" as directive, args), location) -> + (* a very flexible pragma: can retain typedefs, enums, + * structs, unions, or globals (functions or variables) *) + begin + let processArg arg = + try + match arg with + | AStr specifier -> + (* isolate and categorize one symbol name *) + let collection, name = + (* Two words denotes a typedef, enum, struct, or + * union, as in "type foo" or "enum bar". A + * single word denotes a global function or + * variable. *) + let whitespace = Str.regexp "[ \t]+" in + let words = Str.split whitespace specifier in + match words with + | ["type"; name] -> + keepers.typedefs, name + | ["enum"; name] -> + keepers.enums, name + | ["struct"; name] -> + keepers.structs, name + | ["union"; name] -> + keepers.unions, name + | [name] -> + keepers.defines, name + | _ -> + raise Bad_pragma + in + H.add collection name () + | _ -> + raise Bad_pragma + with Bad_pragma -> + badPragma location directive + in + List.iter processArg args + end + | GVarDecl (v, _) -> begin + (* Look for alias attributes, e.g. Linux modules *) + match filterAttributes "alias" v.vattr with + [] -> () (* ordinary prototype. *) + | [Attr("alias", [AStr othername])] -> + H.add keepers.defines othername () + | _ -> E.s (error "Bad alias attribute at %a" d_loc !currentLoc) + end + + (*** Begin CCured-specific checks: ***) + (* these pragmas indirectly require that we keep the function named in + -- the first arguments of boxmodelof and ccuredwrapperof, and + -- the third argument of ccureddeepcopy*. *) + | GPragma (Attr("ccuredwrapper" as directive, attribute :: _), location) -> + begin + match attribute with + | AStr name -> + H.add keepers.defines name () + | _ -> + badPragma location directive + end + | GPragma (Attr("ccuredvararg", funcname :: (ASizeOf t) :: _), location) -> + begin + match t with + | TComp(c,_) when c.cstruct -> (* struct *) + H.add keepers.structs c.cname () + | TComp(c,_) -> (* union *) + H.add keepers.unions c.cname () + | TNamed(ti,_) -> + H.add keepers.typedefs ti.tname () + | TEnum(ei, _) -> + H.add keepers.enums ei.ename () + | _ -> + () + end + | GPragma (Attr(directive, _ :: _ :: attribute :: _), location) + when String.length directive > ccureddeepcopystring_length + && (Str.first_chars directive ccureddeepcopystring_length) + = ccureddeepcopystring -> + begin + match attribute with + | AStr name -> + H.add keepers.defines name () + | _ -> + badPragma location directive + end + (** end CCured-specific stuff **) + | _ -> + () + in + iterGlobals file considerPragma; + keepers + + + +(*********************************************************************** + * + * Function body elimination from pragmas + * + *) + + +(* When performing global slicing, any functions not explicitly marked + * as pragma roots are reduced to mere declarations. This leaves one + * with a reduced source file that still compiles to object code, but + * which contains the bodies of only explicitly retained functions. + *) + +let amputateFunctionBodies keptGlobals file = + let considerGlobal = function + | GFun ({svar = {vname = name} as info}, location) + when not (H.mem keptGlobals name) -> + trace (dprintf "slicing: reducing to prototype: function %s\n" name); + GVarDecl (info, location) + | other -> + other + in + mapGlobals file considerGlobal + + + +(*********************************************************************** + * + * Root collection from pragmas + * + *) + + +let isPragmaRoot keepers = function + | GType ({tname = name}, _) -> + H.mem keepers.typedefs name + | GEnumTag ({ename = name}, _) + | GEnumTagDecl ({ename = name}, _) -> + H.mem keepers.enums name + | GCompTag ({cname = name; cstruct = structure}, _) + | GCompTagDecl ({cname = name; cstruct = structure}, _) -> + let collection = if structure then keepers.structs else keepers.unions in + H.mem collection name + | GVar ({vname = name}, _, _) + | GVarDecl ({vname = name}, _) + | GFun ({svar = {vname = name}}, _) -> + H.mem keepers.defines name + | _ -> + false + + + +(*********************************************************************** + * + * Common root collecting utilities + * + *) + + +let traceRoot reason global = + trace (dprintf "root (%s): %a@!" reason d_shortglobal global); + true + + +let traceNonRoot reason global = + trace (dprintf "non-root (%s): %a@!" reason d_shortglobal global); + false + + +let hasExportingAttribute funvar = + let rec isExportingAttribute = function + | Attr ("constructor", []) -> true + | Attr ("destructor", []) -> true + | _ -> false + in + List.exists isExportingAttribute funvar.vattr + + + +(*********************************************************************** + * + * Root collection from external linkage + * + *) + + +(* Exported roots are those global symbols which are visible to the + * linker and dynamic loader. For variables, this consists of + * anything that is not "static". For functions, this consists of: + * + * - functions bearing a "constructor" or "destructor" attribute + * - functions declared extern but not inline + * - functions declared neither inline nor static + * + * gcc incorrectly (according to C99) makes inline functions visible to + * the linker. So we can only remove inline functions on MSVC. + *) + +let isExportedRoot global = + let result, reason = match global with + | GVar ({vstorage = Static}, _, _) -> + false, "static variable" + | GVar _ -> + true, "non-static variable" + | GFun ({svar = v}, _) -> begin + if hasExportingAttribute v then + true, "constructor or destructor function" + else if v.vstorage = Static then + false, "static function" + else if v.vinline && v.vstorage != Extern + && (!msvcMode || !rmUnusedInlines) then + false, "inline function" + else + true, "other function" + end + | GVarDecl(v,_) when hasAttribute "alias" v.vattr -> + true, "has GCC alias attribute" + | _ -> + false, "neither function nor variable" + in + trace (dprintf "isExportedRoot %a -> %b, %s@!" + d_shortglobal global result reason); + result + + + +(*********************************************************************** + * + * Root collection for complete programs + * + *) + + +(* Exported roots are "main()" and functions bearing a "constructor" + * or "destructor" attribute. These are the only things which must be + * retained in a complete program. + *) + +let isCompleteProgramRoot global = + let result = match global with + | GFun ({svar = {vname = "main"; vstorage = vstorage}}, _) -> + vstorage <> Static + | GFun (fundec, _) + when hasExportingAttribute fundec.svar -> + true + | _ -> + false + in + trace (dprintf "complete program root -> %b for %a@!" result d_shortglobal global); + result + + +(*********************************************************************** + * + * Transitive reachability closure from roots + * + *) + + +(* This visitor recursively marks all reachable types and variables as used. *) +class markReachableVisitor + ((globalMap: (string, Cil.global) H.t), + (currentFunc: fundec option ref)) = object (self) + inherit nopCilVisitor + + method vglob = function + | GType (typeinfo, _) -> + typeinfo.treferenced <- true; + DoChildren + | GCompTag (compinfo, _) + | GCompTagDecl (compinfo, _) -> + compinfo.creferenced <- true; + DoChildren + | GEnumTag (enuminfo, _) + | GEnumTagDecl (enuminfo, _) -> + enuminfo.ereferenced <- true; + DoChildren + | GVar (varinfo, _, _) + | GVarDecl (varinfo, _) + | GFun ({svar = varinfo}, _) -> + varinfo.vreferenced <- true; + DoChildren + | _ -> + SkipChildren + + method vinst = function + Asm (_, tmpls, _, _, _, _) when !msvcMode -> + (* If we have inline assembly on MSVC, we cannot tell which locals + * are referenced. Keep thsem all *) + (match !currentFunc with + Some fd -> + List.iter (fun v -> + let vre = Str.regexp_string (Str.quote v.vname) in + if List.exists (fun tmp -> + try ignore (Str.search_forward vre tmp 0); true + with Not_found -> false) + tmpls + then + v.vreferenced <- true) fd.slocals + | _ -> assert false); + DoChildren + | _ -> DoChildren + + method vvrbl v = + if not v.vreferenced then + begin + let name = v.vname in + if v.vglob then + trace (dprintf "marking transitive use: global %s\n" name) + else + trace (dprintf "marking transitive use: local %s\n" name); + + (* If this is a global, we need to keep everything used in its + * definition and declarations. *) + if v.vglob then + begin + trace (dprintf "descending: global %s\n" name); + let descend global = + ignore (visitCilGlobal (self :> cilVisitor) global) + in + let globals = Hashtbl.find_all globalMap name in + List.iter descend globals + end + else + v.vreferenced <- true; + end; + SkipChildren + + method vexpr (e: exp) = + match e with + Const (CEnum (_, _, ei)) -> ei.ereferenced <- true; + DoChildren + | _ -> DoChildren + + method vtype typ = + let old : bool = + let visitAttrs attrs = + ignore (visitCilAttributes (self :> cilVisitor) attrs) + in + let visitType typ = + ignore (visitCilType (self :> cilVisitor) typ) + in + match typ with + | TEnum(e, attrs) -> + let old = e.ereferenced in + if not old then + begin + trace (dprintf "marking transitive use: enum %s\n" e.ename); + e.ereferenced <- true; + visitAttrs attrs; + visitAttrs e.eattr + end; + old + + | TComp(c, attrs) -> + let old = c.creferenced in + if not old then + begin + trace (dprintf "marking transitive use: compound %s\n" c.cname); + c.creferenced <- true; + + (* to recurse, we must ask explicitly *) + let recurse f = visitType f.ftype in + List.iter recurse c.cfields; + visitAttrs attrs; + visitAttrs c.cattr + end; + old + + | TNamed(ti, attrs) -> + let old = ti.treferenced in + if not old then + begin + trace (dprintf "marking transitive use: typedef %s\n" ti.tname); + ti.treferenced <- true; + + (* recurse deeper into the type referred-to by the typedef *) + (* to recurse, we must ask explicitly *) + visitType ti.ttype; + visitAttrs attrs + end; + old + + | _ -> + (* for anything else, just look inside it *) + false + in + if old then + SkipChildren + else + DoChildren +end + + +let markReachable file isRoot = + (* build a mapping from global names back to their definitions & + * declarations *) + let globalMap = Hashtbl.create 137 in + let considerGlobal global = + match global with + | GFun ({svar = info}, _) + | GVar (info, _, _) + | GVarDecl (info, _) -> + Hashtbl.add globalMap info.vname global + | _ -> + () + in + iterGlobals file considerGlobal; + + let currentFunc = ref None in + + (* mark everything reachable from the global roots *) + let visitor = new markReachableVisitor (globalMap, currentFunc) in + let visitIfRoot global = + if isRoot global then + begin + trace (dprintf "traversing root global: %a\n" d_shortglobal global); + (match global with + GFun(fd, _) -> currentFunc := Some fd + | _ -> currentFunc := None); + ignore (visitCilGlobal visitor global) + end + else + trace (dprintf "skipping non-root global: %a\n" d_shortglobal global) + in + iterGlobals file visitIfRoot + + +(********************************************************************** + * + * Marking and removing of unused labels + * + **********************************************************************) + +(* We keep only one label, preferably one that was not introduced by CIL. + * Scan a list of labels and return the data for the label that should be + * kept, and the remaining filtered list of labels *) +let labelsToKeep (ll: label list) : (string * location * bool) * label list = + let rec loop (sofar: string * location * bool) = function + [] -> sofar, [] + | l :: rest -> + let newlabel, keepl = + match l with + | Case _ | Default _ -> sofar, true + | Label (ln, lloc, isorig) -> begin + match isorig, sofar with + | false, ("", _, _) -> + (* keep this one only if we have no label so far *) + (ln, lloc, isorig), false + | false, _ -> sofar, false + | true, (_, _, false) -> + (* this is an original label; prefer it to temporary or + * missing labels *) + (ln, lloc, isorig), false + | true, _ -> sofar, false + end + in + let newlabel', rest' = loop newlabel rest in + newlabel', (if keepl then l :: rest' else rest') + in + loop ("", locUnknown, false) ll + +class markUsedLabels (labelMap: (string, unit) H.t) = object + inherit nopCilVisitor + + method vstmt (s: stmt) = + match s.skind with + Goto (dest, _) -> + let (ln, _, _), _ = labelsToKeep !dest.labels in + if ln = "" then + E.s (E.bug "rmtmps: destination of statement does not have labels"); + (* Mark it as used *) + H.replace labelMap ln (); + DoChildren + + | _ -> DoChildren + + (* No need to go into expressions or instructions *) + method vexpr _ = SkipChildren + method vinst _ = SkipChildren + method vtype _ = SkipChildren +end + +class removeUnusedLabels (labelMap: (string, unit) H.t) = object + inherit nopCilVisitor + + method vstmt (s: stmt) = + let (ln, lloc, lorig), lrest = labelsToKeep s.labels in + s.labels <- + (if ln <> "" && H.mem labelMap ln then (* We had labels *) + (Label(ln, lloc, lorig) :: lrest) + else + lrest); + DoChildren + + (* No need to go into expressions or instructions *) + method vexpr _ = SkipChildren + method vinst _ = SkipChildren + method vtype _ = SkipChildren +end + +(*********************************************************************** + * + * Removal of unused symbols + * + *) + + +(* regular expression matching names of uninteresting locals *) +let uninteresting = + let names = [ + (* Cil.makeTempVar *) + "__cil_tmp"; + + (* sm: I don't know where it comes from but these show up all over. *) + (* this doesn't seem to do what I wanted.. *) + "iter"; + + (* various macros in glibc's *) + "__result"; + "__s"; "__s1"; "__s2"; + "__s1_len"; "__s2_len"; + "__retval"; "__len"; + + (* various macros in glibc's *) + "__c"; "__res"; + + (* We remove the __malloc variables *) + ] in + + (* optional alpha renaming *) + let alpha = "\\(___[0-9]+\\)?" in + + let pattern = "\\(" ^ (String.concat "\\|" names) ^ "\\)" ^ alpha ^ "$" in + Str.regexp pattern + + +let removeUnmarked file = + let removedLocals = ref [] in + + let filterGlobal global = + match global with + (* unused global types, variables, and functions are simply removed *) + | GType ({treferenced = false}, _) + | GCompTag ({creferenced = false}, _) + | GCompTagDecl ({creferenced = false}, _) + | GEnumTag ({ereferenced = false}, _) + | GEnumTagDecl ({ereferenced = false}, _) + | GVar ({vreferenced = false}, _, _) + | GVarDecl ({vreferenced = false}, _) + | GFun ({svar = {vreferenced = false}}, _) -> + trace (dprintf "removing global: %a\n" d_shortglobal global); + false + + (* retained functions may wish to discard some unused locals *) + | GFun (func, _) -> + let rec filterLocal local = + if not local.vreferenced then + begin + (* along the way, record the interesting locals that were removed *) + let name = local.vname in + trace (dprintf "removing local: %s\n" name); + if not (Str.string_match uninteresting name 0) then + removedLocals := (func.svar.vname ^ "::" ^ name) :: !removedLocals; + end; + local.vreferenced + in + func.slocals <- List.filter filterLocal func.slocals; + (* We also want to remove unused labels. We do it all here, including + * marking the used labels *) + let usedLabels:(string, unit) H.t = H.create 13 in + ignore (visitCilBlock (new markUsedLabels usedLabels) func.sbody); + (* And now we scan again and we remove them *) + ignore (visitCilBlock (new removeUnusedLabels usedLabels) func.sbody); + true + + (* all other globals are retained *) + | _ -> + trace (dprintf "keeping global: %a\n" d_shortglobal global); + true + in + file.globals <- List.filter filterGlobal file.globals; + !removedLocals + + +(*********************************************************************** + * + * Exported interface + * + *) + + +type rootsFilter = global -> bool + +let isDefaultRoot = isExportedRoot + +let rec removeUnusedTemps ?(isRoot : rootsFilter = isDefaultRoot) file = + if !keepUnused || Trace.traceActive "disableTmpRemoval" then + Trace.trace "disableTmpRemoval" (dprintf "temp removal disabled\n") + else + begin + if !E.verboseFlag then + ignore (E.log "Removing unused temporaries\n" ); + + if Trace.traceActive "printCilTree" then + dumpFile defaultCilPrinter stdout "stdout" file; + + (* digest any pragmas that would create additional roots *) + let keepers = categorizePragmas file in + + (* if slicing, remove the bodies of non-kept functions *) + if !Cilutil.sliceGlobal then + amputateFunctionBodies keepers.defines file; + + (* build up the root set *) + let isRoot global = + isPragmaRoot keepers global || + isRoot global + in + + (* mark everything reachable from the global roots *) + clearReferencedBits file; + markReachable file isRoot; + + (* take out the trash *) + let removedLocals = removeUnmarked file in + + (* print which original source variables were removed *) + if false && removedLocals != [] then + let count = List.length removedLocals in + if count > 2000 then + ignore (E.warn "%d unused local variables removed" count) + else + ignore (E.warn "%d unused local variables removed:@!%a" + count (docList ~sep:(chr ',' ++ break) text) removedLocals) + end diff --git a/cil/src/rmtmps.mli b/cil/src/rmtmps.mli new file mode 100644 index 0000000..e29f0c6 --- /dev/null +++ b/cil/src/rmtmps.mli @@ -0,0 +1,82 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * Ben Liblit + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* rmtmps.mli *) +(* remove unused things from cil files: *) +(* - local temporaries introduced but not used *) +(* - global declarations that are not used *) +(* - types that are not used *) +(* - labels that are not used (gn) *) + + +(* Some clients may wish to augment or replace the standard strategy + * for finding the initially reachable roots. The optional + * "isRoot" argument to Rmtmps.removeUnusedTemps grants this + * flexibility. If given, it should name a function which will return + * true if a given global should be treated as a retained root. + * + * Function Rmtmps.isDefaultRoot encapsulates the default root + * collection, which consists of those global variables and functions + * which are visible to the linker and runtime loader. A client's + * root filter can use this if the goal is to augment rather than + * replace the standard logic. Function Rmtmps.isExportedRoot is an + * alternate name for this same function. + * + * Function Rmtmps.isCompleteProgramRoot is an example of an alternate + * root collection. This function assumes that it is operating on a + * complete program rather than just one object file. It treats + * "main()" as a root, as well as any function carrying the + * "constructor" or "destructor" attribute. All other globals are + * candidates for removal, regardless of their linkage. + * + * Note that certain CIL- and CCured-specific pragmas induce + * additional global roots. This functionality is always present, and + * is not subject to replacement by "filterRoots". + *) + +type rootsFilter = Cil.global -> bool +val isDefaultRoot : rootsFilter +val isExportedRoot : rootsFilter +val isCompleteProgramRoot : rootsFilter + +(* process a complete Cil file *) +val removeUnusedTemps: ?isRoot:rootsFilter -> Cil.file -> unit + + +val keepUnused: bool ref (* Set this to true to turn off this module *) +val rmUnusedInlines: bool ref (* Delete unused inline funcs in gcc mode? *) diff --git a/cil/src/testcil.ml b/cil/src/testcil.ml new file mode 100644 index 0000000..0c0ef01 --- /dev/null +++ b/cil/src/testcil.ml @@ -0,0 +1,440 @@ +(* + * + * Copyright (c) 2001-2002, + * George C. Necula + * Scott McPeak + * Wes Weimer + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are + * met: + * + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * 3. The names of the contributors may not be used to endorse or promote + * products derived from this software without specific prior written + * permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS + * IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED + * TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A + * PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER + * OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, + * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, + * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR + * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF + * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING + * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS + * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + * + *) + +(* A test for CIL *) +open Pretty +open Cil +module E = Errormsg + +let lu = locUnknown + +(* If you have trouble try to reproduce the problem on a smaller type. Try + * limiting the maxNesting and integerKinds *) +let integerKinds = [ IChar; ISChar; IUChar; IInt; IUInt; IShort; IUShort; + ILong; IULong; ILongLong; IULongLong ] +let floatKinds = [ FFloat; FDouble ] + +let baseTypes = + (List.map (fun ik -> (1, fun _ -> TInt(ik, []))) integerKinds) + @ (List.map (fun fk -> (1, fun _ -> TFloat(fk, []))) floatKinds) + + +(* Make a random struct *) +let maxNesting = ref 3 (* Maximum number of levels for struct nesting *) +let maxFields = ref 8 (* The maximum number of fields in a struct *) +let useBitfields = ref false +let useZeroBitfields = ref true + + + +(* Collect here the globals *) +let globals: global list ref = ref [] +let addGlobal (g:global) = globals := g :: !globals +let getGlobals () = List.rev !globals + +(* Collect here the statements for main *) +let statements: stmt list ref = ref [] +let addStatement (s: stmt) = statements := s :: !statements +let getStatements () = List.rev !statements + +(* Keep here the main function *) +let main: fundec ref = ref dummyFunDec +let mainRetVal: varinfo ref = ref dummyFunDec.svar + +let assertId = ref 0 +let addAssert (b: exp) (extra: stmt list) : unit = + incr assertId; + addStatement (mkStmt (If(UnOp(LNot, b, intType), + mkBlock (extra @ + [mkStmt (Return (Some (integer !assertId), + lu))]), + mkBlock [], lu))) + +let addSetRetVal (b: exp) (extra: stmt list) : unit = + addStatement + (mkStmt (If(UnOp(LNot, b, intType), + mkBlock (extra @ + [mkStmtOneInstr (Set(var !mainRetVal, one, lu))]), + mkBlock [], lu))) + + +let printfFun: fundec = + let fdec = emptyFunction "printf" in + fdec.svar.vtype <- + TFun(intType, Some [ ("format", charPtrType, [])], true, []); + fdec + + +let memsetFun: fundec = + let fdec = emptyFunction "memset" in + fdec.svar.vtype <- + TFun(voidPtrType, Some [ ("start", voidPtrType, []); + ("v", intType, []); + ("len", uintType, [])], false, []); + fdec + +let checkOffsetFun: fundec = + let fdec = emptyFunction "checkOffset" in + fdec.svar.vtype <- + TFun(voidType, Some [ ("start", voidPtrType, []); + ("len", uintType, []); + ("expected_start", intType, []); + ("expected_width", intType, []); + ("name", charPtrType, []) ], false, []); + fdec + +let checkSizeOfFun: fundec = + let fdec = emptyFunction "checkSizeOf" in + fdec.svar.vtype <- + TFun(voidType, Some [ ("len", uintType, []); + ("expected", intType, []); + ("name", charPtrType, []) ], false, []); + fdec + + +let doPrintf format args = + mkStmtOneInstr (Call(None, Lval(var printfFun.svar), + (Const(CStr format)) :: args, lu)) + + +(* Select among the choices, each with a given weight *) +type 'a selection = int * (unit -> 'a) +let select (choices: 'a selection list) : 'a = + (* Find the total weight *) + let total = List.fold_left (fun sum (w, _) -> sum + w) 0 choices in + if total = 0 then E.s (E.bug "Total for choices = 0\n"); + (* Pick a random number *) + let thechoice = Random.int total in + (* Now get the choice *) + let rec loop thechoice = function + [] -> E.s (E.bug "Ran out of choices\n") + | (w, c) :: rest -> + if thechoice < w then c () else loop (thechoice - w) rest + in + loop thechoice choices + + +(* Generate a new name *) +let nameId = ref 0 +let newName (base: string) = + incr nameId; + base ^ (string_of_int !nameId) + + +(********** Testing of SIZEOF ***********) + +(* The current selection of types *) +let typeChoices : typ selection list ref = ref [] + +let baseTypeChoices : typ selection list ref = ref [] + + +let currentNesting = ref 0 +let mkCompType (iss: bool) = + if !currentNesting >= !maxNesting then (* Replace it with an int *) + select !baseTypeChoices + else begin + incr currentNesting; + let ci = + mkCompInfo iss (newName "comp") + (fun _ -> + let nrFields = 1 + (Random.int !maxFields) in + let rec mkFields (i: int) = + if i = nrFields then [] else begin + let ft = select !typeChoices in + let fname = "f" ^ string_of_int i in + let fname', width = + if not !useBitfields || not (isIntegralType ft) + || (Random.int 8 >= 6) then + fname, None + else begin + let tw = bitsSizeOf ft in (* Assume this works for TInt *) + let w = (if !useZeroBitfields then 0 else 1) + + Random.int (3 * tw / 4) in + (if w = 0 then "___missing_field_name" else fname), Some w + end + in + (fname', ft, width, [], lu) :: mkFields (i + 1) + end + in + mkFields 0) + [] + in + decr currentNesting; + (* Register it with the file *) + addGlobal (GCompTag(ci, lu)); + TComp(ci, []) + end + +(* Make a pointer type. They are all equal so make one to void *) +let mkPtrType () = TPtr(TVoid([]), []) + +(* Make an array type. *) +let mkArrayType () = + if !currentNesting >= !maxNesting then + select !baseTypeChoices + else begin + incr currentNesting; + let at = TArray(select !typeChoices, Some (integer (1 + (Random.int 32))), + []) in + decr currentNesting; + at + end + + +let testSizeOf () = + let doOne (i: int) = +(* ignore (E.log "doOne %d\n" i); *) + (* Make a random type *) + let t = select !typeChoices in + (* Create a global with that type *) + let g = makeGlobalVar (newName "g") t in + addGlobal (GVar(g, {init=None}, lu)); + addStatement (mkStmtOneInstr(Call(None, Lval(var memsetFun.svar), + [ mkAddrOrStartOf (var g); zero; + SizeOfE(Lval(var g))], lu))); + try +(* if i = 0 then ignore (E.log "0: %a\n" d_plaintype t); *) + let bsz = + try bitsSizeOf t (* This is what we are testing *) + with e -> begin + ignore (E.log "Exception %s caught while computing bitsSizeOf(%a)\n" + (Printexc.to_string e) d_type t); + raise (Failure "") + end + in +(* ignore (E.log "1 "); *) + if bsz mod 8 <> 0 then begin + ignore (E.log "bitsSizeOf did not return a multiple of 8\n"); + raise (Failure ""); + end; +(* ignore (E.log "2 "); *) + (* Check the offset of all fields in there *) + let rec checkOffsets (lv: lval) (lvt: typ) = + match lvt with + TComp(c, _) -> + List.iter + (fun f -> + if f.fname <> "___missing_field_name" then + checkOffsets (addOffsetLval (Field(f, NoOffset)) lv) f.ftype) + c.cfields + | TArray (bt, Some len, _) -> + let leni = + match isInteger len with + Some i64 -> Int64.to_int i64 + | None -> E.s (E.bug "Array length is not a constant") + in + let i = Random.int leni in + checkOffsets (addOffsetLval (Index(integer i, NoOffset)) lv) bt + + | _ -> (* Now a base type *) + let _, off = lv in + let start, width = bitsOffset t off in + let setLv (v: exp) = + match lvt with + TFloat (FFloat, _) -> + Set((Mem (mkCast (AddrOf lv) intPtrType), NoOffset), + v, lu) + | TFloat (FDouble, _) -> + Set((Mem (mkCast (AddrOf lv) + (TPtr(TInt(IULongLong, []), []))), NoOffset), + mkCast v (TInt(IULongLong, [])), lu) + + | (TPtr _ | TInt((IULongLong|ILongLong), _)) -> + Set(lv, mkCast v lvt, lu) + | _ -> Set(lv, v, lu) + in + let ucharPtrType = TPtr(TInt(IUChar, []), []) in + let s = + mkStmt (Instr ([ setLv mone; + Call(None, Lval(var checkOffsetFun.svar), + [ mkCast (mkAddrOrStartOf (var g)) + ucharPtrType; + SizeOfE (Lval(var g)); + integer start; + integer width; + (Const(CStr(sprint 80 + (d_lval () lv))))],lu); + setLv zero])) in + addStatement s + in + checkOffsets (var g) t; +(* ignore (E.log "3 ");*) + (* Now check the size of *) + let s = mkStmtOneInstr (Call(None, Lval(var checkSizeOfFun.svar), + [ SizeOfE (Lval (var g)); + integer (bitsSizeOf t); + mkString g.vname ], lu)) in + addStatement s; +(* ignore (E.log "10\n"); *) + with _ -> () + in + + (* Make the composite choices more likely *) + typeChoices := + [ (1, mkPtrType); + (5, mkArrayType); + (5, fun _ -> mkCompType true); + (5, fun _ -> mkCompType false); ] + @ baseTypes; + baseTypeChoices := baseTypes; + useBitfields := false; + maxFields := 4; + for i = 0 to 100 do + doOne i + done; + + (* Now test the bitfields. *) + typeChoices := [ (1, fun _ -> mkCompType true) ]; + baseTypeChoices := [(1, fun _ -> TInt(IInt, []))]; + useBitfields := true; + + for i = 0 to 100 do + doOne i + done; + + (* Now make it a bit more complicated *) + baseTypeChoices := + List.map (fun ik -> (1, fun _ -> TInt(ik, []))) + [IInt; ILong; IUInt; IULong ]; + useBitfields := true; + for i = 0 to 100 do + doOne i + done; + + (* An really complicated now *) + baseTypeChoices := baseTypes; + useBitfields := true; + for i = 0 to 100 do + doOne i + done; + + () + + +(* Now the main tester. Pass to it the name of a command "cmd" that when + * invoked will compile "testingcil.c" and run the result *) +let createFile () = + + assertId := 0; + nameId := 0; + + (* Start a new file *) + globals := []; + statements := []; + + (* Now make a main function *) + main := emptyFunction "main"; + !main.svar.vtype <- TFun(intType, None, false, []); + mainRetVal := makeGlobalVar "retval" intType; + + addGlobal (GVar(!mainRetVal, {init=None}, lu)); + addGlobal (GText("#include \"testcil.h\"\n")); + addStatement (mkStmtOneInstr(Set(var !mainRetVal, zero, lu))); + + (* Add prototype for printf *) + addGlobal (GVar(printfFun.svar, {init=None}, lu)); + addGlobal (GVar(memsetFun.svar, {init=None}, lu)); + + (* now fill in the composites and the code of main. For simplicity we add + * the statements of main in reverse order *) + + testSizeOf (); + + + (* Now add a return 0 at the end *) + addStatement (mkStmt (Return(Some (Lval(var !mainRetVal)), lu))); + + + (* Add main at the end *) + addGlobal (GFun(!main, lu)); + !main.sbody.bstmts <- getStatements (); + + (* Now build the CIL.file *) + let file = + { fileName = "testingcil.c"; + globals = getGlobals (); + globinit = None; + globinitcalled = false; + } + in + (* Print the file *) + let oc = open_out "testingcil.c" in + dumpFile defaultCilPrinter oc "testingcil.c" file; + close_out oc + + + + + +(* initialization code for the tester *) +let randomStateFile = "testcil.random" (* The name of a file where we store + * the state of the random number + * generator last time *) +let doit (command: string) = + while true do + (* Initialize the random no generator *) + begin + try + let randomFile = open_in randomStateFile in + (* The file exists so restore the Random state *) + Random.set_state (Marshal.from_channel randomFile); + ignore (E.log "!! Restoring Random state from %s\n" randomStateFile); + close_in randomFile; + (* Leave the file there until we succeed *) + with _ -> begin + (* The file does not exist *) + Random.self_init (); + (* Save the state of the generator *) + let randomFile = open_out randomStateFile in + Marshal.to_channel randomFile (Random.get_state()) [] ; + close_out randomFile; + end + end; + createFile (); + (* Now compile and run the file *) + ignore (E.log "Running %s\n" command); + let err = Sys.command command in + if err <> 0 then + E.s (E.bug "Failed to run the command: %s (errcode=%d)" command err) + else begin + ignore (E.log "Successfully ran one more round. Press CTRL-C to stop\n"); + (* Delete the file *) + Sys.remove randomStateFile + end + done + diff --git a/cil/test/small1/func.c b/cil/test/small1/func.c new file mode 100644 index 0000000..a0f4e4e --- /dev/null +++ b/cil/test/small1/func.c @@ -0,0 +1,24 @@ +int (*pfun1)(int (*)(int), int); +int (*pfun2)(int (*)(int), int); + +typedef int (*intfun)(int); +intfun arrfun[5]; + +int testf(int k) { + return k; +} + +int foo(int (*bar)(int), int n) { + + pfun1 = foo; + pfun1 = & foo; + pfun1 = * * * pfun2; + + pfun1 = arrfun[4]; + + pfun2(* * testf, 5); + + return 1; +} + + diff --git a/cil/test/small1/hello.c b/cil/test/small1/hello.c new file mode 100644 index 0000000..cbe8ad0 --- /dev/null +++ b/cil/test/small1/hello.c @@ -0,0 +1,8 @@ +#include + + + +int main() { + printf("Hello world\n"); + return 0; +} diff --git a/cil/test/small1/init.c b/cil/test/small1/init.c new file mode 100644 index 0000000..4578b5b --- /dev/null +++ b/cil/test/small1/init.c @@ -0,0 +1,177 @@ +#ifndef __NULLTERM +#define __NULLTERM +#define __SIZED +#endif +#include "testharness.h" + +extern int strcmp(const char*, const char*); + +/* run this with COMPATMODE=1 if compiling directly, since neither GCC nor + * MSVCC fully support the C standard */ +static char *usageplocal = "Usage"; +static char usageescape = 'C'; + +char *usagep = "Usage non-local"; +char *usagep1 = { "Usage in a brace" }; +int g = { 6 } ; + +char usages[] = "Usage string"; +char strange[] = { "several" }; + +char *null = (void*)0; + + +typedef struct s { + char *name; + int data; +} STR; + +extern int afunc(int x); +int (*fptr)(int) = afunc; + +STR a[] = { + {"first", 0}, + {"second", 1}, + {& usages[2], 2}, + { & usageescape, 3}, + { usages, 4}, +}; + + +typedef struct { + struct { + char * a1[10]; + char * a2; + char strbuff[20] __NULLTERM; + } f1; + struct { + int * i1; + } f2[5] __SIZED; +} NESTED; + +NESTED glob1; + +int glob3; +int * glob2 = & glob3; + +int afunc(int a) { + NESTED loc1; + char locbuff[30] __NULLTERM; + char indexbuff[10] __SIZED; + + loc1.f1.a2 = glob1.f1.a2; + + return * loc1.f2[3].i1 + (locbuff[0] - indexbuff[0]); +} + + + +// now initialization for union +union { + struct { + int a; + int *b; + } u1; + int c; +} uarray[] = { 1, 0, 2, 0, 3, 0 }; + + +// now some examples from the standard +int z[4][3] = +{ { 1 }, { 2 }, { 3 }, { 4 } }; + +struct str1 { int a[3]; int b;}; + +struct str1 w[] = +{ { 1 }, { 2 } }; + + +short q[4][3][2] = { + { 1 } , + { 2, 3 }, + { 4, 5, 6} +}; + +short q1[4][3][2] = { + 1, 0, 0, 0, 0, 0, + 2, 3, 0, 0, 0, 0, + 4, 5, 6, 0, 0, 0, +}; + + + +#ifdef _GNUCC +int a1[10] = { + 1, 3, 5, 7, 9, [6] = 8, 6, 4, 2}; + + +enum { member_one, member_two, member_three }; +char *nm[] = { + [member_two] = "member_two", + [member_three] = "member_three", +}; + + +#endif + + + +#define ERROR(n) { printf("Incorrect init: %d\n", n); exit(1); } +// Test the initialization +int main() { + int i; + + struct str1 astr = w[0]; + + if(strcmp(a[0].name, "first")) { + ERROR(0); + } + if(sizeof(uarray) / sizeof(uarray[0]) != 3) { + ERROR(1); + } + if(uarray[2].u1.a != 3) { + ERROR(2); + } + + if(z[2][0] != 3 || + z[2][1] != 0) { + ERROR(4); + } + + if(sizeof(w) / sizeof(w[0]) != 2 || + w[1].a[0] != 2) { + ERROR(5); + } + { + short * ps = (short*)q, * ps1 = (short*)q1; + for(i=0;i /* printf */ +#endif + +extern void exit(int); + +/* Always call E with a non-zero number */ +#define E(n) { printf("Error %d\n", n); exit(n); } +#define SUCCESS { printf("Success\n"); exit(0); } + diff --git a/cil/test/small1/vararg1.c b/cil/test/small1/vararg1.c new file mode 100644 index 0000000..cc710a7 --- /dev/null +++ b/cil/test/small1/vararg1.c @@ -0,0 +1,47 @@ + +/* VA.C: The program below illustrates passing a variable + * number of arguments using the following macros: + * va_start va_arg va_end + * va_list va_dcl (UNIX only) + */ + +#include +#include +int average( int first, ... ); +union vararg_average { + int ints; /* We only pass ints to this one */ +}; + +#include "testharness.h" + +int main( void ) +{ + /* Call with 3 integers (-1 is used as terminator). */ + if(average( 2, 3, 4, -1 ) != 3) E(1); + if(average( 5, 7, 9, 11, 13, -1 ) != 9) E(2); + if(average( -1 ) != 0) E(3); + + SUCCESS; +} + + + +/* Returns the average of a variable list of integers. */ +int average( int first, ... ) +{ + int count = 0, sum = 0, i = first; + va_list marker; + + va_start( marker, first ); /* Initialize variable arguments. */ + while( i != -1 ) + { + sum += i; + count++; + i = va_arg( marker, int); + } + va_end( marker ); /* Reset variable arguments. */ + return( sum ? (sum / count) : 0 ); +} + +// Put this intentionally at the end +#pragma ccuredvararg("average", sizeof(union vararg_average)) diff --git a/cil/test/small1/wchar1.c b/cil/test/small1/wchar1.c new file mode 100644 index 0000000..3306e57 --- /dev/null +++ b/cil/test/small1/wchar1.c @@ -0,0 +1,24 @@ +#include "testharness.h" +#include + +int main() { + wchar_t *wbase = L"Hello" L", world"; + char * w = (char *)wbase; + char * s = "Hello" ", world"; + int i; + + // See if this is little or big endian + short foo = 0x0011; + char little_endian = (int) * (char*)&foo; + + for (i=0; i < 10; i++) { + if (w[i * sizeof(wchar_t)] != (little_endian ? s[i] : 0)) { + E(1); + } + if (w[i * sizeof(wchar_t) + (sizeof(wchar_t)-1)] + != (little_endian ? 0 : s[i])) { + E(2); + } + } + SUCCESS; +} diff --git a/configure b/configure index 0d71d27..fc255b2 100755 --- a/configure +++ b/configure @@ -12,20 +12,28 @@ # # ####################################################################### -cildistrib=cil-1.3.5.tar.gz prefix=/usr/local bindir='$(PREFIX)/bin' libdir='$(PREFIX)/lib/compcert' target='' -usage='Usage: ./configure [options] +prompt() { + echo "$1 [$x] ? " | tr -d '\n' + read y + case "$y" in + "") ;; + none) x="";; + *) x="$y";; + esac +} + +usage='Usage: ./configure [options] target Supported targets: - macosx (PowerPC, MacOS X) + ppc-macosx (PowerPC, MacOS X) ppc-linux (PowerPC, Linux) - ppc-linux-cross (PowerPC, Linux, cross-compilation) arm-linux (ARM, Linux) - arm-linux-cross (ARM, Linux, cross-compilation) + manual (edit configuration file by hand) Options: -prefix Install in /bin and /lib/compcert @@ -51,14 +59,13 @@ while : ; do shift done -if test -z "$target"; then echo "$usage" 1>&2; exit 2; fi - # Per-target configuration case "$target" in - macosx) + ppc-macosx) arch="powerpc" variant="macosx" + system="macosx" cc="gcc -arch ppc" cprepro="gcc -arch ppc -U__GNUC__ -E" casm="gcc -arch ppc -c" @@ -67,37 +74,29 @@ case "$target" in ppc-linux) arch="powerpc" variant="eabi" + system="linux" cc="gcc" cprepro="gcc -U__GNUC__ -E" casm="gcc -c" clinker="gcc" libmath="-lm";; - ppc-linux-cross) - arch="powerpc" - variant="eabi" - cc="ppc-linux-gcc" - cprepro="ppc-linux-gcc -U__GNUC__ -E" - casm="ppc-linux-gcc -c" - clinker="ppc-linux-gcc" - libmath="-lm";; arm-linux) arch="arm" variant="linux" + system="linux" cc="gcc" cprepro="gcc -U__GNUC__ -E" casm="gcc -c" clinker="gcc" libmath="-lm";; - arm-linux-cross) - arch="arm" - variant="linux" - cc="arm-linux-gcc" - cprepro="arm-linux-gcc -U__GNUC__ -E" - casm="arm-linux-gcc -c" - clinker="arm-linux-gcc" - libmath="-lm";; + manual) + ;; + "") + echo "No target specified." 1>&2 + echo "$usage" 1>&2 + exit 2;; *) - echo "Unsupported configuration '$target'" 1>&2 + echo "Unknown target '$target'." 1>&2 echo "$usage" 1>&2 exit 2;; esac @@ -109,20 +108,58 @@ cat > Makefile.config <> Makefile.config <> Makefile.config <<'EOF' + +# Target architecture +# ARCH=powerpc +# ARCH=arm +ARCH= + +# Target ABI +# VARIANT=macosx # for PowerPC / MacOS X +# VARIANT=eabi # for PowerPC / Linux and other SVR4 or EABI platforms +# VARIANT=linux # for ARM +VARIANT= + +# Target operating system and development environment +# See $(ARCH)/PrintAsm.ml for possible choices +SYSTEM= + +# C compiler for compiling library files +CC=gcc + +# Preprocessor for .c files +CPREPRO=gcc -U__GNUC__ -E + +# Assembler for assembling .s files +CASM=gcc -c + +# Linker +CLINKER=gcc + +# Math library +LIBMATH=-lm + +# CIL configuration target -- do not change +EOF +fi # Extract and configure Cil -set -e -tar xzf $cildistrib -for i in cil.patch/*; do patch -p1 < $i; done (cd cil && ./configure) # Extract 'ARCHOS' info from Cil configuration @@ -131,14 +168,31 @@ grep '^ARCHOS=' cil/config.log >> Makefile.config # Summarize configuration +if test "$target" = "manual"; then +cat <